/[mcclim]/mcclim/presentations.lisp
ViewVC logotype

Contents of /mcclim/presentations.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.86 - (show annotations)
Wed Dec 16 13:15:38 2009 UTC (4 years, 4 months ago) by rstrandh
Branch: MAIN
CVS Tags: HEAD
Changes since 1.85: +1 -1 lines
Fixed a typo.

Thanks to Stas Boukarev.
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com)
4 ;;; (c) copyright 2001,2002 by Tim Moore (moore@bricoworks.com)
5 ;;; This library is free software; you can redistribute it and/or
6 ;;; modify it under the terms of the GNU Library General Public
7 ;;; License as published by the Free Software Foundation; either
8 ;;; version 2 of the License, or (at your option) any later version.
9 ;;;
10 ;;; This library is distributed in the hope that it will be useful,
11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;; Library General Public License for more details.
14 ;;;
15 ;;; You should have received a copy of the GNU Library General Public
16 ;;; License along with this library; if not, write to the
17 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
18 ;;; Boston, MA 02111-1307 USA.
19
20 ;;; Implementation of the presentation type system, presentation generic
21 ;;; functions and methods, presentation translators, finding an applicable
22 ;;;presentation.
23
24 (in-package :clim-internals)
25
26 ;;; PRESENTATION class
27
28 (defvar *allow-sensitive-inferiors* t)
29
30 (defclass presentation-mixin (presentation)
31 ((object :accessor presentation-object :initarg :object)
32 (type :accessor presentation-type :initarg :type)
33 (view :accessor presentation-view :initarg :view)
34 (single-box :accessor presentation-single-box :initarg :single-box
35 :initform nil)
36 (modifier :reader presentation-modifier :initarg :modifier :initform nil)
37 (is-sensitive :reader is-sensitive :initarg :is-sensitive
38 :initform *allow-sensitive-inferiors*)))
39
40
41 (defclass standard-presentation
42 (presentation-mixin standard-sequence-output-record)
43 ())
44
45 (defvar *print-presentation-verbose* nil)
46
47 (defmethod print-object ((self standard-presentation) stream)
48 (print-unreadable-object (self stream :type t :identity t)
49 (with-bounding-rectangle* (x1 y1 x2 y2)
50 self
51 (format stream "~D:~D,~D:~D ~S" x1 x2 y1 y2 (presentation-type self))
52 (when *print-presentation-verbose*
53 (format stream " ~S" (presentation-object self))))))
54
55 (defmacro with-output-as-presentation ((stream object type
56 &rest key-args
57 &key modifier single-box
58 (allow-sensitive-inferiors t)
59 parent
60 (record-type
61 ''standard-presentation)
62 &allow-other-keys)
63 &body body)
64 (declare (ignore parent single-box modifier))
65 (setq stream (stream-designator-symbol stream '*standard-output*))
66 (multiple-value-bind (decls with-body)
67 (get-body-declarations body)
68 (with-gensyms (record-arg continuation)
69 (with-keywords-removed (key-args (:record-type
70 :allow-sensitive-inferiors))
71 `(flet ((,continuation ()
72 ,@decls
73 ,@with-body))
74 (declare (dynamic-extent #',continuation))
75 (if (and (output-recording-stream-p ,stream)
76 *allow-sensitive-inferiors*)
77 (with-new-output-record
78 (,stream ,record-type ,record-arg
79 :object ,object
80 :type (expand-presentation-type-abbreviation
81 ,type)
82 ,@key-args)
83 (let ((*allow-sensitive-inferiors*
84 ,allow-sensitive-inferiors))
85 (,continuation)))
86 (,continuation)))))))
87
88 (defgeneric ptype-specializer (type)
89 (:documentation "The specializer to use for this type in a presentation
90 method lambda list"))
91
92 ;;; Metaclass for presentation types. For presentation types not associated
93 ;;; with CLOS classes, objects with this metaclass are used as a proxy for the
94 ;;; type during presentation method dispatch. We don't prevent these
95 ;;; presentation proxies from being subclasses of standard-object,
96 ;;; but in presentation method dispatch we remove methods on standard
97 ;;; object for presentation types that are not CLOS classes. The
98 ;;; presentation type metaclass for T is the builtin object T instead
99 ;;; of a presentation-type-class; in this way we can avoid weirdness
100 ;;; with T being a subtype of standard-object!
101 ;;;
102
103 (defclass presentation-type ()
104 ((type-name :accessor type-name :initarg :type-name
105 :documentation "The name assigned to the presentation
106 type, as opposed to the name constructed for the class")
107 (ptype-specializer :accessor ptype-specializer :initarg :ptype-specializer)
108 (parameters :accessor parameters :initarg :parameters :initform nil)
109 (parameters-lambda-list :accessor parameters-lambda-list
110 :initarg :parameters-lambda-list
111 :initform nil
112 :documentation "The parameters lambda list, altered for use in destructuring bind")
113 (options :accessor options :initarg :options :initform nil)
114 (options-lambda-list :accessor options-lambda-list
115 :initarg :options-lambda-list
116 :initform nil
117 :documentation "The options lambda list,
118 altered for use in destructuring bind")
119 (inherit-from :accessor inherit-from
120 :initarg :inherit-from
121 :documentation "Inherit-from form with dummys substituted")
122 (inherit-from-function :accessor inherit-from-function
123 :initarg :inherit-from-function
124 :documentation "Function that returns the inherit-from form")
125 (description :accessor description :initarg :description)
126 (history :accessor history :initarg :history :initform nil
127 :documentation "Who knows?")
128 (parameters-are-types :accessor parameters-are-types
129 :initarg :parameters-are-types
130 :initform nil)
131 (expansion-function :accessor expansion-function
132 :initarg :expansion-function
133 :documentation "A function which expands the typespec
134 fully, including defaulting parameters and options.")))
135
136 (defmethod initialize-instance :after ((obj presentation-type) &key)
137 (unless (slot-boundp obj 'ptype-specializer)
138 (setf (slot-value obj 'ptype-specializer)
139 (make-presentation-type-name (slot-value obj 'type-name)))))
140
141 (defclass presentation-type-class (presentation-type standard-class)
142 ())
143
144 (defmethod clim-mop:validate-superclass ((class presentation-type-class)
145 (super standard-class))
146 t)
147
148 (defclass clos-presentation-type (presentation-type)
149 ((clos-class :accessor clos-class :initarg :clos-class
150 :documentation "Holds the class object of the CLOS class of this presentation type")))
151
152 (defmethod initialize-instance :after ((obj clos-presentation-type)
153 &key (ptype-specializer
154 nil
155 ptype-specializer-p))
156 (declare (ignore ptype-specializer))
157 (unless ptype-specializer-p
158 (setf (slot-value obj 'ptype-specializer)
159 (slot-value obj 'type-name))))
160
161 (defmethod history ((ptype standard-class))
162 "Default for CLOS types that are not defined explicitly as
163 presentation types."
164 t)
165
166 (defvar *builtin-t-class* (find-class t))
167
168 ;;;Methods for the T presentation type
169 (defmethod type-name ((class (eql *builtin-t-class*)))
170 t)
171
172 (defmethod ptype-specializer ((class (eql *builtin-t-class*)))
173 t)
174
175 (defmethod parameters ((class (eql *builtin-t-class*)))
176 nil)
177
178 (defmethod parameters-lambda-list ((class (eql *builtin-t-class*)))
179 nil)
180
181 (defmethod options ((class (eql *builtin-t-class*)))
182 nil)
183
184 (defmethod options-lambda-list ((class (eql *builtin-t-class*)))
185 nil)
186
187 (defmethod inherit-from ((class (eql *builtin-t-class*)))
188 nil)
189
190 (defmethod inherit-from-function ((class (eql *builtin-t-class*)))
191 #'(lambda (type)
192 (declare (ignore type))
193 nil))
194
195 (defmethod description ((class (eql *builtin-t-class*)))
196 "The supertype of all presentation types.")
197
198 (defmethod history ((class (eql *builtin-t-class*)))
199 t)
200
201 (defmethod parameters-are-types ((class (eql *builtin-t-class*)))
202 nil)
203
204 (defmethod expansion-function ((class (eql *builtin-t-class*)))
205 #'(lambda (type)
206 (declare (ignore type))
207 t))
208
209 (defun make-presentation-type-name (name)
210 (intern (format nil "(presentation-type ~A::~A)"
211 (package-name (symbol-package name))
212 (symbol-name name))
213 :clim-internals))
214
215 (defun transform-parameters-lambda-list (ll)
216 "Change the destructuring lambda list so that any optional or key variable
217 that has no default is supplied with '*"
218 (when (atom ll)
219 (return-from transform-parameters-lambda-list ll))
220 (let ((state 'required))
221 (loop for lambda-var in ll
222 collect
223 (cond ((member lambda-var lambda-list-keywords :test #'eq)
224 (setq state lambda-var)
225 lambda-var)
226 ((eq state '&optional)
227 (if (atom lambda-var)
228 `(,lambda-var '*)
229 (cons (transform-parameters-lambda-list (car lambda-var))
230 (or (cdr lambda-var) '('*)))))
231 ((eq state '&key)
232 (cond ((atom lambda-var)
233 `(,lambda-var '*))
234 ((atom (car lambda-var))
235 (cons (car lambda-var)
236 (or (cdr lambda-var) '('*))))
237 (t (destructuring-bind
238 ((var pattern)
239 &optional (default nil default-p)
240 &rest supplied-tail)
241 lambda-var
242 `((,var ,(transform-parameters-lambda-list
243 pattern))
244 ,(if default-p
245 default
246 '*)
247 ,@supplied-tail)))))
248 ((member state '(required &rest &body &whole))
249 (when (eq state '&whole)
250 (setq state 'required))
251 (transform-parameters-lambda-list lambda-var))
252 (t lambda-var)))))
253
254 (defun fake-params-args (ll)
255 (let ((state 'required))
256 (flet ((do-arg (lambda-var)
257 (let ((var-name (symbol-name lambda-var)))
258 (cond ((or (eq state 'required) (eq state '&optional))
259 (list (gensym var-name)))
260 ((eq state '&key)
261 `(,(intern var-name :keyword) ,(gensym var-name)))
262 (t nil)))))
263 (loop for lambda-var in ll
264 append (cond ((member lambda-var lambda-list-keywords :test #'eq)
265 (setq state lambda-var)
266 nil)
267 ((eq state '&whole)
268 (setq state 'required)
269 nil)
270 ((atom lambda-var)
271 (do-arg lambda-var))
272 ((consp lambda-var)
273 (let ((var (car lambda-var)))
274 (do-arg (if (and (eq state '&key) (consp var))
275 (car var)
276 var)))))))))
277
278 ;;; Yet another variation on a theme...
279
280 (defun get-all-params (ll)
281 (unless ll
282 (return-from get-all-params nil))
283 (when (atom ll)
284 (return-from get-all-params (list ll)))
285 (let ((state 'required))
286 (loop for arg in ll
287 append (cond ((member arg lambda-list-keywords :test #'eq)
288 (setq state arg)
289 nil)
290 ((eq state 'required)
291 (get-all-params arg))
292 ((or (eq state '&optional) (eq state '&aux))
293 (if (atom arg)
294 (list arg)
295 (get-all-params (car arg))))
296 ((eq state '&key)
297 (cond ((atom arg)
298 (list arg))
299 ((atom (car arg))
300 (list (car arg)))
301 (t (get-all-params (cadar arg)))))
302 ((member state '(required &rest &body &whole))
303 (when (eq state '&whole)
304 (setq state 'required))
305 (get-all-params arg))
306 (t nil)))))
307
308 ;;; ...And another. Given a lambda list, return a form that replicates the
309 ;;; structure of the argument with variables filled in.
310
311 (defun map-over-lambda-list (function ll
312 &key (pass-lambda-list-keywords nil))
313 (declare (ignore function pass-lambda-list-keywords))
314 (unless ll
315 (return-from map-over-lambda-list nil))
316 (when (atom ll)
317 (return-from map-over-lambda-list ll))
318 (loop for args-tail = ll then (cdr args-tail)))
319
320 (defun make-keyword (sym)
321 (intern (symbol-name sym) :keyword))
322
323 (defun cull-keywords (keys prop-list)
324 (let ((plist (copy-list prop-list)))
325 (loop for key in keys
326 do (remf plist key))
327 plist))
328
329 (defun recreate-lambda-list (ll)
330 "Helper function. Returns a form that, when evaluated inside a
331 DESTRUCTURING-BIND using ll, recreates the argument list with all defaults
332 filled in."
333 (unless ll
334 (return-from recreate-lambda-list nil))
335 (when (atom ll)
336 (return-from recreate-lambda-list ll))
337 (let ((state 'required)
338 (rest-var nil)
339 (has-keys nil)
340 (keys nil)
341 (allow-other-keys nil))
342 (loop for arg in ll
343 append (cond ((member arg lambda-list-keywords :test #'eq)
344 (setq state arg)
345 (when (eq arg '&key)
346 (setq has-keys t))
347 (when (eq arg '&allow-other-keys)
348 (setq allow-other-keys t))
349 nil)
350 ((eq state '&whole)
351 nil)
352 ((eq state 'required)
353 (list (recreate-lambda-list arg)))
354 ((eq state '&optional)
355 (if (atom arg)
356 (list arg)
357 (list (recreate-lambda-list (car arg)))))
358 ((or (eq state '&rest) (eq state '&body))
359 (setq rest-var arg)
360 nil)
361 ((eq state '&key)
362 (let ((key nil)
363 (var nil))
364 (cond ((atom arg)
365 (setq key (make-keyword arg)
366 var arg))
367 ((atom (car arg))
368 (setq key (make-keyword (car arg))
369 var (car arg)))
370
371 (t (destructuring-bind
372 ((keyword pattern) &rest tail)
373 arg
374 (declare (ignore tail))
375 (setq key keyword
376 var (recreate-lambda-list
377 pattern)))))
378 (push key keys)
379 (list key var)))
380 (t nil))
381 into result-form
382 finally (cond ((or (not rest-var)
383 (and has-keys
384 (not allow-other-keys)))
385 (return `(list ,@result-form)))
386 ((not has-keys)
387 (return `(list* ,@result-form ,rest-var)))
388 (t (return `(list* ,@result-form
389 (cull-keywords ',(nreverse keys)
390 ,rest-var))))))))
391
392 (defun transform-options-lambda-list (ll)
393 "Return a legal lambda list given an options specification"
394 (let ((descriptionp nil))
395 (loop for spec in ll
396 collect (if (atom spec)
397 (progn
398 (when (eq (make-keyword spec) :description)
399 (setq descriptionp t))
400 spec)
401 (progn
402 (let ((key (if (atom (car spec))
403 (make-keyword (car spec))
404 (caar spec))))
405 (when (eq key :description)
406 (setq descriptionp t)))
407 (ldiff spec (cdddr spec))))
408 into specs
409 finally (return `(&key
410 ,@specs
411 ,@(unless descriptionp
412 `(((:description ,(gensym))))))))))
413
414
415 ;;; External function
416 (declaim (inline presentation-type-name))
417
418 (defun presentation-type-name (type)
419 (cond ((atom type)
420 type)
421 ((atom (car type))
422 (car type))
423 (t (caar type))))
424
425 (defun decode-parameters (type)
426 (cond ((atom type)
427 nil)
428 ((atom (car type))
429 (cdr type))
430 (t (cdar type))))
431
432 (defun decode-options (type)
433 (if (or (atom type) (atom (car type)))
434 nil
435 (cdr type)))
436
437 (defun make-inherit-from-lambda (params-ll options-ll form)
438 (let ((type (gensym "TYPE")))
439 `(lambda (,type)
440 (destructuring-bind ,params-ll (decode-parameters ,type)
441 (declare (ignorable ,@(get-all-params params-ll)))
442 (destructuring-bind ,options-ll (decode-options ,type)
443 (declare (ignorable ,@(get-all-params options-ll)))
444 ,form)))))
445
446
447 (eval-when (:compile-toplevel :load-toplevel :execute)
448 (defmacro with-presentation-type-decoded ((name
449 &optional (params nil params-p)
450 (options nil options-p))
451 type &body body)
452 (let ((type-var (gensym "TYPE-VAR")))
453 `(let* ((,type-var ,type)
454 (,name (presentation-type-name ,type-var))
455 ,@(and params-p `((,params (decode-parameters ,type-var))))
456 ,@(and options-p `((,options (decode-options ,type-var)))))
457 ,@body)))
458 )
459
460 (eval-when (:compile-toplevel :load-toplevel :execute)
461 (defun make-expansion-lambda (params-ll options-ll)
462 (let ((params-form (recreate-lambda-list params-ll))
463 (options-form (recreate-lambda-list options-ll))
464 (parameters (gensym))
465 (options (gensym)))
466 `(lambda (typespec)
467 (with-presentation-type-decoded (name ,parameters ,options)
468 typespec
469 (make-type-spec name
470 (destructuring-bind ,params-ll
471 ,parameters
472 ,params-form)
473 (destructuring-bind ,options-ll
474 ,options
475 ,options-form)))))))
476
477 (defvar *presentation-type-table* (make-hash-table :test #'eq))
478
479 (setf (gethash t *presentation-type-table*) (find-class t))
480
481 (defgeneric get-ptype-metaclass (type))
482
483 (defmethod get-ptype-metaclass ((type symbol))
484 (let ((maybe-meta (gethash type *presentation-type-table*)))
485 (if maybe-meta
486 (get-ptype-metaclass maybe-meta)
487 (let ((system-meta (find-class type nil)))
488 (and (typep system-meta 'standard-class)
489 system-meta)))))
490
491 (defmethod get-ptype-metaclass ((type presentation-type-class))
492 type)
493
494 (defmethod get-ptype-metaclass ((type clos-presentation-type))
495 (clos-class type))
496
497 (defmethod get-ptype-metaclass ((type (eql *builtin-t-class*)))
498 type)
499
500 (defmethod get-ptype-metaclass ((type class))
501 type)
502
503 (defmethod get-ptype-metaclass (type)
504 (error "~A is not the name of a presentation type" type))
505
506 ;;; external functions
507 (defun find-presentation-type-class (name &optional (errorp t) environment)
508 (declare (ignore environment))
509 (let ((metaclass (get-ptype-metaclass name)))
510 (cond (metaclass
511 metaclass)
512 (errorp
513 (error "~S is not the name of a presentation type" name))
514 (t nil))))
515
516 (defun class-presentation-type-name (class &optional environment)
517 (declare (ignore environment))
518 (cond ((typep class 'presentation-type)
519 (type-name class))
520 (t (class-name class))))
521
522 ;;; For the presentation class T, the stand in object must not be a
523 ;;; standard-object. So... why not the symbol T?
524
525 (defvar *class-t-prototype* t)
526
527 (defun prototype-or-error (name)
528 (let ((ptype-meta (get-ptype-metaclass name)))
529 (unless ptype-meta
530 (error "~S is an unknown presentation type" name))
531 (when (eq ptype-meta *builtin-t-class*)
532 (return-from prototype-or-error *class-t-prototype*))
533 (unless (clim-mop:class-finalized-p ptype-meta)
534 (clim-mop:finalize-inheritance ptype-meta))
535 (or (clim-mop:class-prototype ptype-meta)
536 (error "Couldn't find a prototype for ~S" name))))
537
538 (defun safe-cpl (class)
539 (unless (clim-mop:class-finalized-p class)
540 (clim-mop:finalize-inheritance class))
541 (clim-mop:class-precedence-list class))
542
543 (defun get-ptype (name)
544 (or (gethash name *presentation-type-table*)
545 (let ((meta (find-class name nil)))
546 (and (typep meta 'standard-class)
547 meta))))
548
549 (defgeneric presentation-ptype-supers (type)
550 (:documentation "Gets a list of the presentation type objects for those
551 supertypes of TYPE that are presentation types"))
552
553 (defmethod presentation-ptype-supers ((type symbol))
554 (let ((ptype (gethash type *presentation-type-table*)))
555 (if ptype
556 (presentation-ptype-supers ptype)
557 nil)))
558
559 (defmethod presentation-ptype-supers ((type presentation-type-class))
560 (mapcan #'(lambda (class)
561 (typecase class
562 (presentation-type
563 (list class))
564 (standard-class
565 (let ((clos-ptype (gethash (class-name class)
566 *presentation-type-table*)))
567 (if clos-ptype
568 (list clos-ptype)
569 nil)))
570 (t
571 nil)))
572 (clim-mop:class-direct-superclasses type)))
573
574 (defmethod presentation-ptype-supers ((type clos-presentation-type))
575 (presentation-ptype-supers (clos-class type)))
576
577 ;;; External function
578
579 (defun presentation-type-direct-supertypes (type)
580 (with-presentation-type-decoded (name)
581 type
582 (let ((supers (presentation-ptype-supers name)))
583 (mapcar #'class-presentation-type-name supers))))
584
585 (eval-when (:compile-toplevel :load-toplevel :execute)
586 (defmethod ptype-specializer ((type symbol))
587 (let ((ptype (gethash type *presentation-type-table*)))
588 (cond (ptype
589 (ptype-specializer ptype))
590 ((find-class type nil)
591 (ptype-specializer (find-class type)))
592 ;; Assume it's a forward referenced CLOS class.
593 (t type))))
594
595 (defmethod ptype-specializer ((type standard-class))
596 (class-name type)))
597
598 ;;; We need to patch defclass in every implementation to record a CLOS
599 ;;; class at compiletime. On the other hand, I think we can assume
600 ;;; that if a CLOS class exists at compile time, it will exist at
601 ;;; load/run time too.
602 (eval-when (:compile-toplevel :load-toplevel :execute)
603 #-(or excl cmu sbcl openmcl)
604 (defun compile-time-clos-p (name)
605 (let ((meta (find-class name nil)))
606 (and meta
607 (typep meta 'standard-class))))
608
609 #+(or excl cmu sbcl openmcl)
610 (defun compile-time-clos-p (name)
611 (let ((metaclass (find-class name nil)))
612 (or (and metaclass
613 (typep metaclass 'standard-class))
614 (clim-lisp-patch::compile-time-clos-class-p name))))
615
616 (defun make-default-description (name)
617 "Create a description string from the type name"
618 (let ((downcase-name (string-downcase name)))
619 (setq downcase-name (nsubstitute-if-not #\Space
620 #'alphanumericp
621 downcase-name))
622 (string-trim " " downcase-name)))
623
624 (defun record-presentation-type (name parameters params-ll options options-ll
625 inherit-from-func description history
626 parameters-are-types
627 compile-time-p
628 supers expansion-func)
629 (let* ((fake-name (make-presentation-type-name name))
630 (ptype-class-args (list :type-name name
631 :parameters parameters
632 :parameters-lambda-list params-ll
633 :options options
634 :options-lambda-list options-ll
635 :inherit-from-function inherit-from-func
636 :description description
637 :history history
638 :parameters-are-types parameters-are-types
639 :expansion-function expansion-func))
640 (ptype-meta
641 (if compile-time-p
642 (apply #'make-instance
643 (if (compile-time-clos-p name)
644 'clos-presentation-type
645 'presentation-type)
646 ptype-class-args)
647 (let* ((clos-meta (find-class name nil))
648 (closp (typep clos-meta 'standard-class)))
649 (if closp
650 (apply #'make-instance 'clos-presentation-type
651 :clos-class clos-meta
652 ptype-class-args)
653 (let ((directs (mapcan
654 #'(lambda (super)
655 (if (eq super t)
656 nil
657 (list (or (get-ptype-metaclass
658 super)
659 super))))
660 supers)))
661 (apply #'clim-mop:ensure-class fake-name
662 :name fake-name
663 :metaclass 'presentation-type-class
664 :direct-superclasses directs
665 ptype-class-args)))))))
666 (setf (gethash name *presentation-type-table*) ptype-meta)
667 ptype-meta))
668 ); eval-when
669
670 (defgeneric massage-type-for-super (type-name super-name type-spec)
671 (:documentation "translate TYPE-SPEC from that of TYPE-NAME to one
672 suitable for SUPER-NAME"))
673
674 ;;; The default: there ain't no direct specification
675
676 (defmethod massage-type-for-super ((type-name t) (super-name t) type-spec)
677 (declare (ignore type-spec))
678 (values nil nil))
679
680 ;;; Load-time actions for define-presentation-type
681 (defmacro %define-presentation-type (name parameters params-ll
682 options options-ll
683 inherit-from inherit-from-lambda
684 description history parameters-are-types)
685 (declare (ignore inherit-from))
686 (let* ((inherit-from-func (coerce inherit-from-lambda 'function))
687 (inherit-typespec (funcall inherit-from-func
688 (cons name (fake-params-args params-ll))))
689 (superclasses (if inherit-typespec
690 (with-presentation-type-decoded
691 (super-name super-params)
692 inherit-typespec
693 (if (eq super-name 'and)
694 (mapcar #'presentation-type-name super-params)
695 (list super-name)))
696 nil))
697 (expansion-lambda (make-expansion-lambda params-ll options-ll)))
698 `(progn
699 (record-presentation-type ',name ',parameters ',params-ll ',options
700 ',options-ll #',inherit-from-lambda
701 ',description ',history
702 ',parameters-are-types
703 nil ',superclasses
704 #',expansion-lambda)
705 ,@(cond ((eq (presentation-type-name inherit-typespec) 'and)
706 (loop for super in superclasses
707 for i from 0
708 append (unless (or (not (atom super))
709 (eq super 'satisfies)
710 (eq super 'not))
711 `((defmethod massage-type-for-super
712 ((type-name (eql ',name))
713 (super-name (eql ',super))
714 type)
715 (values (nth ,i
716 (cdr (,inherit-from-lambda
717 type)))
718 t))))))
719 (superclasses
720 `((defmethod massage-type-for-super
721 ((type-name (eql ',name))
722 (super-name (eql ',(car superclasses)))
723 type)
724 (values (,inherit-from-lambda type) t))))
725 (t nil)))))
726
727 (defmacro define-presentation-type (name parameters
728 &key options inherit-from
729 (description
730 (make-default-description name))
731 (history t)
732 parameters-are-types)
733 (let* ((params-ll (transform-parameters-lambda-list parameters))
734 (options-ll (transform-options-lambda-list options))
735 (inherit-from-func (make-inherit-from-lambda params-ll
736 options-ll
737 inherit-from)))
738 `(progn
739 (eval-when (:compile-toplevel)
740 (record-presentation-type ',name ',parameters ',params-ll ',options
741 ',options-ll #',inherit-from-func
742 ',description ',history
743 ',parameters-are-types
744 t nil nil))
745 (eval-when (:load-toplevel :execute)
746 (%define-presentation-type ,name ,parameters ,params-ll
747 ,options ,options-ll
748 ,inherit-from ,inherit-from-func
749 ,description ,history
750 ,parameters-are-types)))))
751
752 ;;; These are used by the presentation method MOP code, but are
753 ;;; actually defined in presentation-defs.lisp after the forms for these
754 ;;; types are executed.
755
756 (defvar *ptype-t-class*)
757
758 (defvar *ptype-expression-class*)
759
760 (defvar *ptype-form-class*)
761
762 (defun presentation-type-parameters (type-name &optional env)
763 (declare (ignore env))
764 (let ((ptype (gethash type-name *presentation-type-table*)))
765 (unless ptype
766 (error "~S is not the name of a presentation type" type-name))
767 (parameters ptype)))
768
769 (defun presentation-type-options (type-name &optional env)
770 (declare (ignore env))
771 (let ((ptype (gethash type-name *presentation-type-table*)))
772 (unless ptype
773 (error "~S is not the name of a presentation type" type-name))
774 (options ptype)))
775
776 (defmacro with-presentation-type-parameters ((type-name type) &body body)
777 (let ((ptype (get-ptype type-name)))
778 (unless (or ptype (compile-time-clos-p type-name))
779 (warn "~S is not a presentation type name." type-name))
780 (if (typep ptype 'presentation-type)
781 (let* ((params-ll (parameters-lambda-list ptype))
782 (params (gensym "PARAMS"))
783 (type-var (gensym "TYPE-VAR"))
784 (ignorable-vars (get-all-params params-ll)))
785 `(let ((,type-var ,type))
786 (unless (eq ',type-name (presentation-type-name ,type-var))
787 (error "Presentation type specifier ~S does not match the name ~S"
788 ,type-var
789 ',type-name))
790 (let ((,params (decode-parameters ,type-var)))
791 (declare (ignorable ,params))
792 (destructuring-bind ,params-ll ,params
793 (declare (ignorable ,@ignorable-vars))
794 ,@body))))
795 `(let ()
796 ,@body))))
797
798
799 (defmacro with-presentation-type-options ((type-name type) &body body)
800 (let ((ptype (get-ptype type-name)))
801 (unless (or ptype (compile-time-clos-p type-name))
802 (warn "~S is not a presentation type name." type-name))
803 (if (typep ptype 'presentation-type)
804 (let* ((options-ll (options-lambda-list ptype))
805 (options (gensym "OPTIONS"))
806 (type-var (gensym "TYPE-VAR"))
807 (ignorable-vars (get-all-params options-ll)))
808 `(let ((,type-var ,type))
809 (unless (eq ',type-name (presentation-type-name ,type-var))
810 (error "Presentation type specifier ~S does not match the name ~S"
811 ,type-var
812 ',type-name))
813 (let ((,options (decode-options ,type-var)))
814 (declare (ignorable ,options))
815 (destructuring-bind ,options-ll ,options
816 (declare (ignorable ,@ignorable-vars))
817 ,@body))))
818 `(let ()
819 ,@body))))
820
821 (eval-when (:compile-toplevel :load-toplevel :execute)
822 (defvar *presentation-type-abbreviations* (make-hash-table :test #'eq)))
823
824 (defmacro define-presentation-type-abbreviation (name parameters
825 equivalent-type
826 &key options)
827 `(eval-when (:compile-toplevel :load-toplevel :execute)
828 (setf (gethash ',name *presentation-type-abbreviations*)
829 #',(make-inherit-from-lambda
830 (transform-parameters-lambda-list parameters)
831 (transform-options-lambda-list options)
832 equivalent-type))))
833
834 (defun make-type-spec (name parameters options)
835 (cond (options
836 `((,name ,@parameters) ,@options))
837 (parameters
838 `(,name ,@parameters))
839 (t name)))
840
841 (defun expand-presentation-type-abbreviation-1 (type &optional env)
842 (flet ((expand-list (specs)
843 (loop with expand-any-p = nil
844 for spec in specs
845 collect (multiple-value-bind (expansion expanded)
846 (expand-presentation-type-abbreviation-1 spec env)
847 (setq expand-any-p (or expand-any-p expanded))
848 expansion)
849 into new-params
850 finally (return (if expand-any-p
851 (values new-params t)
852 (values specs nil))))))
853 (with-presentation-type-decoded (name parms options)
854 type
855 (case name
856 ((and or sequence sequence-enumerated)
857 (multiple-value-bind (expansion expanded)
858 (expand-list parms)
859 (if expanded
860 (values (make-type-spec name expansion options) t)
861 (values type nil))))
862 (t (let* ((expander (gethash name *presentation-type-abbreviations*)))
863 (flet ((copy-description (expanded-typespec)
864 (with-presentation-type-decoded (expand-name
865 expand-params
866 expand-options)
867 expanded-typespec
868 (let ((description (getf options :description))
869 (expand-desc (getf expand-options :description)))
870 (if (and description
871 (null expand-desc))
872 (make-type-spec expand-name
873 expand-params
874 `(:description ,description
875 ,@expand-options))
876 expanded-typespec)))))
877 (if expander
878 (values (copy-description (funcall expander type)) t)
879 (values type nil)))))))))
880
881
882 (defun expand-presentation-type-abbreviation (type &optional env)
883 (let ((expand-any-p nil))
884 (loop
885 (multiple-value-bind (expansion expanded)
886 (expand-presentation-type-abbreviation-1 type env)
887 (if expanded
888 (progn
889 (setq expand-any-p t)
890 (setq type expansion))
891 (return (values type expand-any-p)))))))
892
893 (defun make-presentation-type-specifier (name-and-params &rest options)
894 (with-presentation-type-decoded (name)
895 name-and-params
896 (let ((ptype (gethash name *presentation-type-table*)))
897 (unless ptype
898 (return-from make-presentation-type-specifier name-and-params))
899 (with-presentation-type-decoded (name parameters defaults)
900 (funcall (expansion-function ptype) name-and-params)
901 (declare (ignore name parameters))
902 (loop for (key val) on options by #'cddr
903 for default = (getf defaults key)
904 unless (equal val default)
905 nconc (list key val) into needed-options
906 finally (return (if needed-options
907 `(,name-and-params ,@needed-options)
908 name-and-params)))))))
909
910 ;;; Presentation methods.
911 ;;;
912 ;;; The basic dispatch is performed via CLOS instances that are standins
913 ;;; for the presentation types. There are a couple of complications to
914 ;;; this simple plan. First, methods on the presentation type class
915 ;;;STANDARD-OBJECT -- if there are any -- should not be applicable to
916 ;;;presentation types that are not CLOS classes, even though STANDARD-OBJECT
917 ;;;is in the class precedence list of the standin object. Our own methods on
918 ;;;COMPUTE-APPLICABLE-METHODS-USING-CLASSES and COMPUTE-APPLICABLE-METHODS
919 ;;;remove methods specialized on standard-object.
920 ;;;
921 ;;; The second major complication is the whole raison d'etre of presentation
922 ;;; type methods: type parameters and options are massaged so that
923 ;;; applicable methods written on the supertype of a presentation type get
924 ;;; parameters and options in the expected form. "Real" CLIM apparently
925 ;;; does this massaging in the body of the effective method and passes the
926 ;;; massaged parameters as an argument into the method. We do it with a
927 ;;; function call within the body of the method. This is potentially more
928 ;;; expensive, but caching should help that. Our method has the huge
929 ;;; advantage of working with any method combination.
930
931 (defclass presentation-gf-info ()
932 ((generic-function-name :accessor generic-function-name
933 :initarg :generic-function-name)
934 (lambda-list :accessor lambda-list :initarg :lambda-list)
935 (type-key-arg :accessor type-key-arg :initarg :type-key-arg)
936 (parameters-arg :accessor parameters-arg :initarg :parameters-arg
937 :initform nil)
938 (options-arg :accessor options-arg :initarg :options-arg :initform nil)
939 (type-arg-position :accessor type-arg-position
940 :initarg :type-arg-position)))
941
942 (defvar *presentation-gf-table* (make-hash-table :test #'eq))
943
944 (defclass presentation-generic-function (standard-generic-function)
945 ()
946 (:metaclass clim-mop:funcallable-standard-class))
947
948 (defvar *standard-object-class* (find-class 'standard-object))
949
950 #-scl
951 (defmethod clim-mop:compute-applicable-methods-using-classes :around
952 ((gf presentation-generic-function) classes)
953 (multiple-value-bind (methods success)
954 (call-next-method)
955 (let ((ptype-class (car classes)))
956 (if (or (null success)
957 (not (typep ptype-class 'presentation-type-class)))
958 (values methods success)
959 (values (remove-if #'(lambda (method)
960 (eq (car (clim-mop:method-specializers
961 method))
962 *standard-object-class*))
963 methods)
964 t)))))
965
966 #+scl
967 (defmethod clim-mop:compute-applicable-methods-using-classes :around
968 ((gf presentation-generic-function) classes)
969 (multiple-value-bind (methods success non-class-positions)
970 (call-next-method)
971 (let ((ptype-class (car classes)))
972 (if (or (null success)
973 (not (typep ptype-class 'presentation-type-class)))
974 (values methods non-class-positions non-class-positions)
975 (values (remove-if #'(lambda (method)
976 (eq (car (clim-mop:method-specializers
977 method))
978 *standard-object-class*))
979 methods)
980 t
981 non-class-positions)))))
982
983 (defun method-applicable (method arguments)
984 (loop for arg in arguments
985 for specializer in (clim-mop:method-specializers method)
986 always (cond ((typep specializer 'clim-mop:eql-specializer)
987 (eql arg (clim-mop:eql-specializer-object specializer)))
988 ((typep arg specializer)
989 t)
990 ((and (not (typep (class-of arg)
991 'presentation-type-class))
992 (or (eq specializer *ptype-form-class*)
993 (eq specializer *ptype-expression-class*)))
994 t)
995 (t nil))))
996
997 (defmethod compute-applicable-methods :around
998 ((gf presentation-generic-function) arguments)
999 (let ((methods (call-next-method)))
1000 (if (typep (class-of (car arguments)) 'presentation-type-class)
1001 (remove-if #'(lambda (method)
1002 (eq (car (clim-mop:method-specializers method))
1003 *standard-object-class*))
1004 methods)
1005 methods)))
1006
1007 ;;; The hard part of presentation methods: translating the type specifier for
1008 ;;; superclasses.
1009 ;;;
1010
1011 (defmethod type-name ((type standard-class))
1012 (class-name type))
1013
1014 (defmethod expansion-function ((type standard-class))
1015 #'(lambda (typespec)
1016 (with-presentation-type-decoded (name)
1017 typespec
1018 name)))
1019
1020 (defmethod presentation-ptype-supers ((type standard-class))
1021 (mapcan #'(lambda (class)
1022 (let ((ptype (gethash (class-name class)
1023 *presentation-type-table*)))
1024 (and ptype (list ptype))))
1025 (clim-mop:class-direct-superclasses type)))
1026
1027 (defun translate-specifier-for-type (type-name super-name specifier)
1028 (when (eq type-name super-name)
1029 (return-from translate-specifier-for-type (values specifier t)))
1030 (multiple-value-bind (translation found)
1031 (massage-type-for-super type-name super-name specifier)
1032 (when found
1033 (return-from translate-specifier-for-type (values translation t))))
1034 (loop for super in (presentation-ptype-supers type-name)
1035 do (multiple-value-bind (translation found)
1036 (translate-specifier-for-type (type-name super)
1037 super-name
1038 (massage-type-for-super
1039 type-name
1040 (type-name super)
1041 specifier))
1042 (when found
1043 (return-from translate-specifier-for-type (values translation
1044 t)))))
1045 (values super-name nil))
1046
1047 ;;; XXX can options be specified without parameters? I think not.
1048 (defmacro define-presentation-generic-function (generic-function-name
1049 presentation-function-name
1050 lambda-list
1051 &rest options)
1052 (let ((type-key-arg (car lambda-list))
1053 (parameters-arg (cadr lambda-list))
1054 (options-arg (caddr lambda-list)))
1055 (unless (or (eq type-key-arg 'type-key) (eq type-key-arg 'type-class))
1056 (error "The first argument in a presentation generic function must be
1057 type-key or type-class"))
1058 (unless (eq parameters-arg 'parameters)
1059 (setq parameters-arg nil))
1060 (unless (eq options-arg 'options)
1061 (setq options-arg nil))
1062 (let* ((gf-lambda-list (cons type-key-arg
1063 (cond (options-arg
1064 (cdddr lambda-list))
1065 (parameters-arg
1066 (cddr lambda-list))
1067 (t (cdr lambda-list)))))
1068 ;; XXX should check that it's required
1069 (type-arg-pos (position 'type gf-lambda-list)))
1070 (unless type-arg-pos
1071 (error "type must appear as an argument in a presentation generic
1072 function lambda list"))
1073 `(progn
1074 (eval-when (:compile-toplevel :load-toplevel :execute)
1075 (setf
1076 (gethash ',presentation-function-name *presentation-gf-table*)
1077 (make-instance 'presentation-gf-info
1078 :generic-function-name ',generic-function-name
1079 :lambda-list ',lambda-list
1080 :type-key-arg ',type-key-arg
1081 :parameters-arg ',parameters-arg
1082 :options-arg ',options-arg
1083 :type-arg-position ,type-arg-pos)))
1084 (defgeneric ,generic-function-name ,gf-lambda-list
1085 (:generic-function-class presentation-generic-function)
1086 ,@options)))))
1087
1088 (defun parse-method-body (args)
1089 (loop for arglist on args
1090 for (arg) = arglist
1091 while (atom arg)
1092 collect arg into qualifiers
1093 finally (if (and (consp arglist)
1094 (consp (cdr arglist))
1095 (consp (cadr arglist))
1096 (eq (caadr arglist) 'declare))
1097 (return (values qualifiers arg (cadr arglist) (cddr arglist)))
1098 (return (values qualifiers arg nil (cdr arglist))))))
1099
1100 (defun type-name-from-type-key (type-key)
1101 (if (symbolp type-key)
1102 't
1103 (type-name (class-of type-key))))
1104
1105 (defmacro define-presentation-method (name &rest args)
1106 (when (eq name 'presentation-subtypep)
1107 ;; I feel so unclean!
1108 (return-from define-presentation-method
1109 `(define-subtypep-method ,@args)))
1110 (let ((gf (gethash name *presentation-gf-table*)))
1111 (unless gf
1112 (error "~S is not a presentation generic function" name))
1113 (with-accessors ((parameters-arg parameters-arg)
1114 (options-arg options-arg))
1115 gf
1116 (multiple-value-bind (qualifiers lambda-list decls body)
1117 (parse-method-body args)
1118 (let ((type-arg (nth (1- (type-arg-position gf)) lambda-list)))
1119 (unless (consp type-arg)
1120 (error "Type argument in presentation method must be specialized"))
1121 (unless (eq (car type-arg) 'type)
1122 (error "Type argument mismatch with presentation generic function
1123 definition"))
1124 (destructuring-bind (type-var type-name) type-arg
1125 (let* ((method-ll `((,(type-key-arg gf)
1126 ,(ptype-specializer type-name))
1127 ,@(copy-list lambda-list)))
1128 (real-body body)
1129 (massaged-type (gensym "MASSAGED-TYPE")))
1130 (when options-arg
1131 (setq real-body
1132 `((let ((,options-arg (decode-options ,massaged-type)))
1133 (declare (ignorable ,options-arg))
1134 (with-presentation-type-options (,type-name
1135 ,massaged-type)
1136 ,@real-body)))))
1137 (when parameters-arg
1138 (setq real-body
1139 `((let ((,parameters-arg (decode-parameters
1140 ,massaged-type)))
1141 (declare (ignorable ,parameters-arg))
1142 (with-presentation-type-parameters (,type-name
1143 ,massaged-type)
1144 ,@real-body)))))
1145 (when (or options-arg parameters-arg)
1146 (setq real-body
1147 `((let ((,massaged-type (translate-specifier-for-type
1148 (type-name-from-type-key
1149 ,(type-key-arg gf))
1150 ',type-name
1151 ,type-var)))
1152 ,@real-body))))
1153 (setf (nth (type-arg-position gf) method-ll) type-var)
1154 `(defmethod ,(generic-function-name gf) ,@qualifiers ,method-ll
1155 ,@(when decls
1156 (list decls))
1157 (block ,name
1158 ,@real-body)))))))))
1159
1160
1161
1162 (defmacro define-default-presentation-method (name &rest args)
1163 (let ((gf (gethash name *presentation-gf-table*)))
1164 (unless gf
1165 (error "~S is not a presentation generic function" name))
1166 (multiple-value-bind (qualifiers lambda-list decls body)
1167 (parse-method-body args)
1168 `(defmethod ,(generic-function-name gf) ,@qualifiers (,(type-key-arg gf)
1169 ,@lambda-list)
1170 (declare (ignorable ,(type-key-arg gf))
1171 ,@(cdr decls))
1172 (block ,name
1173 ,@body)))))
1174
1175 ;;; Somewhat obsolete, but keep it around for apply-presentation-generic-function.
1176 (defun %funcall-presentation-generic-function (name gf type-arg-position
1177 &rest args)
1178 (declare (ignore name))
1179 (let* ((type-spec (nth (1- type-arg-position) args))
1180 (ptype-name (presentation-type-name type-spec)))
1181 (apply gf (prototype-or-error ptype-name) args)))
1182
1183 ;;; I wonder if this pattern for preserving order of evaluation is
1184 ;;; has a more general use...
1185
1186 (defmacro funcall-presentation-generic-function (name &rest args)
1187 (let ((gf (gethash name *presentation-gf-table*)))
1188 (unless gf
1189 (error "~S is not a presentation generic function" name))
1190 (let* ((rebound-args (loop for arg in args
1191 unless (symbolp arg)
1192 collect (list (gensym "ARG") arg)))
1193 (gf-name (generic-function-name gf))
1194 (type-spec-var (nth (1- (type-arg-position gf)) args)))
1195 `(let ,rebound-args
1196 (,gf-name (prototype-or-error (presentation-type-name
1197 ,(or (first (find type-spec-var rebound-args :key #'second))
1198 type-spec-var)))
1199 ,@(mapcar #'(lambda (arg)
1200 ;; Order of evaluation doesn't matter
1201 ;; for symbols, and this shuts up
1202 ;; warnings about arguments in a
1203 ;; keyword position not being
1204 ;; constant. By the way, why do we
1205 ;; care about order of evaluation
1206 ;; here? -trh
1207 (or (first (find arg rebound-args :key #'second))
1208 arg)) args))))))
1209
1210 (defmacro apply-presentation-generic-function (name &rest args)
1211 (let ((gf (gethash name *presentation-gf-table*)))
1212 (unless gf
1213 (error "~S is not a presentation generic function" name))
1214 `(apply #'%funcall-presentation-generic-function ',name
1215 #',(generic-function-name gf)
1216 ,(type-arg-position gf)
1217 ,@args)))
1218
1219 ;;; 23.7.1 Defining Presentation Translators
1220
1221 (defclass presentation-translator ()
1222 ((name :reader name :initarg :name)
1223 (from-type :reader from-type :initarg :from-type)
1224 (to-type :reader to-type :initarg :to-type)
1225 (gesture :reader gesture :initarg :gesture)
1226 (tester :reader tester :initarg :tester)
1227 (tester-definitive :reader tester-definitive :initarg :tester-definitive)
1228 (documentation :reader translator-documentation :initarg :documentation)
1229 (pointer-documentation :reader pointer-documentation
1230 :initarg :pointer-documentation)
1231 (menu :reader menu :initarg :menu)
1232 (priority :reader priority :initarg :priority :initform 0)
1233 (translator-function :reader translator-function
1234 :initarg :translator-function)))
1235
1236 (defmethod initialize-instance :after ((obj presentation-translator)
1237 &key &allow-other-keys)
1238 (unless (slot-boundp obj 'pointer-documentation)
1239 (setf (slot-value obj 'pointer-documentation)
1240 (translator-documentation obj))))
1241
1242 (defmethod print-object ((obj presentation-translator) stream)
1243 (print-unreadable-object (obj stream :identity t)
1244 (format stream "Translator ~S from ~S to ~S"
1245 (name obj) (from-type obj) (to-type obj))))
1246
1247 (defclass presentation-action (presentation-translator)
1248 ())
1249
1250 (defmethod initialize-instance :after ((obj presentation-action)
1251 &key &allow-other-keys)
1252 (setf (slot-value obj 'tester-definitive) t))
1253
1254 (defmethod print-object ((obj presentation-action) stream)
1255 (print-unreadable-object (obj stream :identity t)
1256 (format stream "Action from ~S to ~S" (from-type obj) (to-type obj))))
1257
1258 ;;; This lives in a command table
1259
1260 (defvar *current-translator-cache-generation* 0
1261 "This is incremented whenever presentation translators are defined,
1262 and used to ensure that presentation-translators-caches are up to date.")
1263
1264 (defclass translator-table ()
1265 ((translators :accessor translators :initarg :translators
1266 :initform (make-hash-table :test #'eq)
1267 :documentation "Translators keyed by name.")
1268 (simple-type-translators :accessor simple-type-translators
1269 :initarg :simple-type-translators
1270 :initform (make-hash-table :test #'eq)
1271 :documentation "Holds transators with a simple
1272 from-type (i.e. doesn't contain \"or\" or \"and\").")
1273 (translator-cache-generation :accessor translator-cache-generation :initform 0)
1274 (presentation-translators-cache
1275 :writer (setf presentation-translators-cache)
1276 :initform (make-hash-table :test #'equal))))
1277
1278 (defun invalidate-translator-caches ()
1279 (incf *current-translator-cache-generation*))
1280
1281 (defmethod presentation-translators-cache ((table translator-table))
1282 (with-slots ((cache presentation-translators-cache)
1283 (generation translator-cache-generation))
1284 table
1285 (unless (or (= generation *current-translator-cache-generation*)
1286 (zerop (hash-table-size cache)))
1287 (clrhash cache))
1288 (setf generation *current-translator-cache-generation*)
1289 cache))
1290
1291
1292
1293 ;;; Returns function lambda list, ignore forms
1294 (defun make-translator-ll (translator-args)
1295 (let ((object-arg (find "object" translator-args :test #'string-equal))
1296 (ignore-form nil))
1297 (if object-arg
1298 (setq translator-args (remove "object" translator-args
1299 :test #'string-equal))
1300 (progn
1301 (setq object-arg (gensym "OBJECT-ARG"))
1302 (setq ignore-form `(declare (ignore ,object-arg)))))
1303 (values `(,object-arg &key ,@translator-args &allow-other-keys)
1304 ignore-form)))
1305
1306 (defun default-translator-tester (object-arg &key &allow-other-keys)
1307 (declare (ignore object-arg))
1308 t)
1309
1310 (defun add-translator (table translator)
1311 ;; Remove old one.
1312 (with-accessors ((translators translators)
1313 (simple-type-translators simple-type-translators))
1314 table
1315 (let ((old (gethash (name translator) translators)))
1316 (when old
1317 (setf (gethash (presentation-type-name (from-type old))
1318 simple-type-translators)
1319 (remove old
1320 (gethash (presentation-type-name (from-type old))
1321 simple-type-translators))))
1322 (invalidate-translator-caches)
1323 (setf (gethash (name translator) translators) translator)
1324 (push translator
1325 (gethash (from-type translator) simple-type-translators))
1326 translator)))
1327
1328 (defun make-translator-fun (args body)
1329 (multiple-value-bind (ll ignore)
1330 (make-translator-ll args)
1331 `(lambda ,ll
1332 ,@(and ignore (list ignore))
1333 ,@body)))
1334
1335 (defun make-documentation-fun (doc-arg)
1336 (cond ((and doc-arg (symbolp doc-arg))
1337 doc-arg)
1338 ((consp doc-arg)
1339 (make-translator-fun (car doc-arg) (cdr doc-arg)))
1340 ((stringp doc-arg)
1341 `(lambda (object &key stream &allow-other-keys)
1342 (declare (ignore object))
1343 (write-string ,doc-arg stream)))
1344 ((null doc-arg)
1345 `(lambda (object &key presentation stream &allow-other-keys)
1346 (present object (presentation-type presentation)
1347 :stream stream :sensitive nil)))
1348 (t (error "Can't handle doc-arg ~S" doc-arg))))
1349
1350 (defmacro define-presentation-translator
1351 (name (from-type to-type command-table &rest translator-options &key
1352 (gesture :select)
1353 (tester 'default-translator-tester testerp)
1354 (tester-definitive (if testerp nil t))
1355 (documentation nil documentationp)
1356 (pointer-documentation nil pointer-documentation-p)
1357 (menu t)
1358 (priority 0)
1359 (translator-class 'presentation-translator)
1360 &allow-other-keys)
1361 arglist
1362 &body body)
1363 ;; null tester should be the same as no tester
1364 (unless tester
1365 (setq tester 'default-translator-tester)
1366 (setq tester-definitive t))
1367 (let* ((real-from-type (expand-presentation-type-abbreviation from-type))
1368 (real-to-type (expand-presentation-type-abbreviation to-type)))
1369 (with-keywords-removed (translator-options
1370 (:gesture :tester :tester-definitive :documentation
1371 :pointer-documentation :menu :priority
1372 :translator-class))
1373 `(add-translator (presentation-translators (find-command-table
1374 ',command-table))
1375 (make-instance
1376 ',translator-class
1377 :name ',name
1378 :from-type ',real-from-type
1379 :to-type ',real-to-type
1380 :gesture ,(if (eq gesture t)
1381 t
1382 `(gethash ',gesture *gesture-names*))
1383 :tester ,(if (symbolp tester)
1384 `',tester
1385 `#',(make-translator-fun (car tester)
1386 (cdr tester)))
1387 :tester-definitive ',tester-definitive
1388 :documentation #',(make-documentation-fun
1389 (if documentationp
1390 documentation
1391 (command-name-from-symbol
1392 name)))
1393 ,@(when pointer-documentation-p
1394 `(:pointer-documentation
1395 #',(make-documentation-fun
1396 pointer-documentation)))
1397 :menu ',menu
1398 :priority ,priority
1399 :translator-function #',(make-translator-fun arglist
1400 body)
1401 ,@translator-options)))))
1402
1403 (defmacro define-presentation-action
1404 (name (from-type to-type command-table &key
1405 (gesture :select)
1406 (tester 'default-translator-tester)
1407 (documentation nil documentationp)
1408 (pointer-documentation nil pointer-documentation-p)
1409 (menu t)
1410 (priority 0))
1411 arglist
1412 &body body)
1413 (let* ((real-from-type (expand-presentation-type-abbreviation from-type))
1414 (real-to-type (expand-presentation-type-abbreviation to-type)))
1415 `(add-translator (presentation-translators (find-command-table
1416 ',command-table))
1417 (make-instance
1418 'presentation-action
1419 :name ',name
1420 :from-type ',real-from-type
1421 :to-type ',real-to-type
1422 :gesture ,(if (eq gesture t)
1423 t
1424 `(gethash ',gesture *gesture-names*))
1425 :tester ,(if (symbolp tester)
1426 `',tester
1427 `#',(make-translator-fun (car tester)
1428 (cdr tester)))
1429 :tester-definitive t
1430 :documentation #',(make-documentation-fun (if documentationp
1431 documentation
1432 (command-name-from-symbol
1433 name)))
1434 ,@(when pointer-documentation-p
1435 `(:pointer-documentation
1436 #',(make-documentation-fun pointer-documentation)))
1437 :menu ',menu
1438 :priority ,priority
1439 :translator-function #',(make-translator-fun arglist
1440 body)))))
1441
1442 ;;; define-presentation-to-command-translator is in commands.lisp
1443
1444 ;;; 23.7.2 Presentation Translator Functions
1445
1446 ;;; Used by map-over-presentation-type-supertypes as well
1447
1448 (defun map-over-ptype-superclasses (function type)
1449 (let* ((type-name (presentation-type-name type))
1450 (type-meta (get-ptype-metaclass type-name))
1451 (type-is-ptype (typep type-meta 'presentation-type-class)))
1452 (unless type-meta
1453 (return-from map-over-ptype-superclasses nil))
1454 (loop
1455 for super-meta in (safe-cpl type-meta)
1456 ;; structure classes?
1457 when (and (or (typep super-meta 'standard-class)
1458 (eq super-meta *builtin-t-class*))
1459 (not (and type-is-ptype
1460 (eq super-meta *standard-object-class*))))
1461 do (funcall function super-meta))))
1462
1463 ;;; This is to implement the requirement on presentation translators
1464 ;;; for doing subtype calculations without reference to type
1465 ;;; parameters. We are generous in that we return T when we are
1466 ;;; unsure, to give translator testers a chance to accept or reject
1467 ;;; the translator. This is essentially
1468 ;;; (multiple-value-bind (yesp surep)
1469 ;;; (presentation-subtypep maybe-subtype type)
1470 ;;; (or yesp (not surep)))
1471 ;;; except faster.
1472 (defun stupid-subtypep (maybe-subtype type)
1473 "Return t if maybe-subtype is a presentation subtype of type, regardless of
1474 parameters."
1475 (when (or (eq maybe-subtype nil) (eq type t))
1476 (return-from stupid-subtypep t))
1477 (when (eql maybe-subtype type)
1478 (return-from stupid-subtypep t))
1479 (let ((maybe-subtype-name (presentation-type-name maybe-subtype))
1480 (type-name (presentation-type-name type)))
1481 (cond
1482 ;; see DEFUN PRESENTATION-SUBTYPEP for some caveats
1483 ((eq maybe-subtype-name 'or)
1484 (let ((or-types (decode-parameters maybe-subtype)))
1485 (every (lambda (x) (stupid-subtypep x type)) or-types)))
1486 ((eq type-name 'and)
1487 (stupid-subtypep maybe-subtype (car (decode-parameters type))))
1488 ((eq type-name 'or)
1489 (let ((or-types (decode-parameters type)))
1490 (some (lambda (x) (stupid-subtypep maybe-subtype x)) or-types)))
1491 ((eq maybe-subtype-name 'and)
1492 ;; this clause is actually not conservative, but probably in a
1493 ;; way that no-one will complain about too much. Basically, we
1494 ;; will only return T if the first type in the AND (which is
1495 ;; treated specially by CLIM) is subtypep the maybe-supertype
1496 (stupid-subtypep (car (decode-parameters maybe-subtype)) type))
1497 (t
1498 (let ((subtype-meta (get-ptype-metaclass maybe-subtype-name))
1499 (type-meta (get-ptype-metaclass type-name)))
1500 (unless (and subtype-meta type-meta)
1501 (return-from stupid-subtypep nil))
1502 (map-over-ptype-superclasses #'(lambda (super)
1503 (when (eq type-meta super)
1504 (return-from stupid-subtypep t)))
1505 maybe-subtype-name)
1506 nil)))))
1507
1508 (defun find-presentation-translators (from-type to-type command-table)
1509 (let* ((command-table (find-command-table command-table))
1510 (from-name (presentation-type-name from-type))
1511 (to-name (presentation-type-name to-type))
1512 (cached-translators (gethash (cons from-name to-name)
1513 (presentation-translators-cache
1514 (presentation-translators
1515 command-table)))))
1516 (when cached-translators
1517 (return-from find-presentation-translators cached-translators))
1518 (let ((translator-vector (make-array 8 :adjustable t :fill-pointer 0))
1519 (table-counter 0))
1520 (do-command-table-inheritance (table command-table)
1521 (let ((translator-map (simple-type-translators
1522 (presentation-translators table))))
1523 (flet ((get-translators (type)
1524 (let ((translators (gethash type translator-map)))
1525 (loop for translator in translators
1526 if (stupid-subtypep (to-type translator)
1527 to-type)
1528 do (vector-push-extend (cons translator
1529 table-counter)
1530 translator-vector)))))
1531 (map-over-ptype-superclasses #'(lambda (super)
1532 (get-translators (type-name
1533 super)))
1534 from-name)))
1535 (incf table-counter))
1536 (let ((from-super-names nil))
1537 (map-over-ptype-superclasses #'(lambda (super)
1538 (push (type-name super)
1539 from-super-names))
1540 from-name)
1541 (setq from-super-names (nreverse from-super-names))
1542 ;; The Spec mentions "high order priority" and "low order priority"
1543 ;; without saying what that is! Fortunately, the Franz CLIM user guide
1544 ;; says that high order priority is (floor priority 10), low order
1545 ;; priority is (mod priority 10.) That's pretty wacked...
1546 (flet ((translator-lessp (a b)
1547 (destructuring-bind (translator-a . table-num-a)
1548 a
1549 (destructuring-bind (translator-b . table-num-b)
1550 b
1551 (multiple-value-bind (hi-a low-a)
1552 (floor (priority translator-a))
1553 (multiple-value-bind (hi-b low-b)
1554 (floor (priority translator-b))
1555 ;; High order priority
1556 (cond ((> hi-a hi-b)
1557 (return-from translator-lessp t))
1558 ((< hi-a hi-b)
1559 (return-from translator-lessp nil)))
1560 ;; more specific
1561 (let ((a-precedence (position
1562 (presentation-type-name
1563 (from-type translator-a))
1564 from-super-names))
1565 (b-precedence (position
1566 (presentation-type-name
1567 (from-type translator-b))
1568 from-super-names)))
1569 (cond ((< a-precedence b-precedence)
1570 (return-from translator-lessp t))
1571 ((> a-precedence b-precedence)
1572 (return-from translator-lessp nil))))
1573 ;; Low order priority
1574 (cond ((> low-a low-b)
1575 (return-from translator-lessp t))
1576 ((< low-a low-b)
1577 (return-from translator-lessp nil)))))
1578 ;; Command table inheritance
1579 (< table-num-a table-num-b)))))
1580 ;; Add translators to their caches.
1581 (setf (gethash (cons from-name to-name)
1582 (presentation-translators-cache
1583 (presentation-translators command-table)))
1584 (remove-duplicates
1585 (map 'list
1586 #'car
1587 (sort translator-vector #'translator-lessp)))))))))
1588
1589 (defgeneric call-presentation-translator
1590 (translator presentation context-type frame event window x y))
1591
1592 (defmethod call-presentation-translator
1593 ((translator presentation-translator) presentation context-type
1594 frame event window x y)
1595 ;; Let the translator return an explict ptype of nil to, in effect, abort the
1596 ;; presentation throw.
1597 (multiple-value-call
1598 #'(lambda (object &optional (ptype context-type) options)
1599 (values object ptype options))
1600 (funcall (translator-function translator)
1601 (presentation-object presentation)
1602 :presentation presentation
1603 :context-type context-type
1604 :frame frame
1605 :event event
1606 :window window
1607 :x x
1608 :y y)))
1609
1610 (defmethod call-presentation-translator
1611 ((translator presentation-action) presentation context-type
1612 frame event window x y)
1613 (funcall (translator-function translator)
1614 (presentation-object presentation)
1615 :presentation presentation
1616 :context-type context-type
1617 :frame frame
1618 :event event
1619 :window window
1620 :x x
1621 :y y)
1622 (values nil nil nil))
1623
1624 (defun document-presentation-translator (translator
1625 presentation
1626 context-type
1627 frame
1628 event
1629 window
1630 x y
1631 &key (stream *standard-output*)
1632 (documentation-type :normal))
1633 (funcall (if (eq documentation-type :normal)
1634 (translator-documentation translator)
1635 (pointer-documentation translator))
1636 (presentation-object presentation)
1637 :presentation presentation
1638 :context-type context-type
1639 :frame frame
1640 :event event
1641 :window window
1642 :x x
1643 :y y
1644 :stream stream))
1645
1646 ;;; :button is a pointer button state, for performing matches where we want to
1647 ;;; restrict the match to certain gestures but don't have a real event.
1648
1649 (defun test-presentation-translator
1650 (translator presentation context-type frame window x y
1651 &key event (modifier-state 0) for-menu button)
1652 (flet ((match-gesture (gesture event modifier-state)
1653 (let ((modifiers (if event
1654 (event-modifier-state event)
1655 modifier-state)))
1656 (or (eq gesture t)
1657 for-menu
1658 (loop for g in gesture
1659 thereis (and (eql modifiers (caddr g))
1660 (or (and button (eql button (cadr g)))
1661 (and (null button)
1662 (or (null event)
1663 (eql (pointer-event-button
1664 event)
1665 (cadr g)))))))))))
1666 (let* ((from-type (from-type translator)))
1667 (unless (match-gesture (gesture translator) event modifier-state)
1668 (return-from test-presentation-translator nil))
1669 (unless (or (null (decode-parameters from-type))
1670 (presentation-typep (presentation-object presentation)
1671 from-type))
1672 (return-from test-presentation-translator nil))
1673 (unless (or (null (tester translator))
1674 (funcall (tester translator)
1675 (presentation-object presentation)
1676 :presentation presentation
1677 :context-type context-type
1678 :frame frame
1679 :window window
1680 :x x
1681 :y y
1682 :event event))
1683 (return-from test-presentation-translator nil))
1684 (unless (or (tester-definitive translator)
1685 (null (decode-parameters context-type))
1686 (presentation-typep (call-presentation-translator
1687 translator
1688 presentation
1689 context-type
1690 frame
1691 event
1692 window
1693 x y)
1694 context-type))
1695 (return-from test-presentation-translator nil))))
1696 t)
1697
1698 ;;; presentation-contains-position moved to presentation-defs.lisp
1699
1700 (defun map-over-presentations-containing-position (func record x y)
1701 "maps recursively over all presentations in record, including record."
1702 (map-over-output-records-containing-position
1703 #'(lambda (child)
1704 (when (output-record-p child) ; ? What else could it be? --moore
1705 (map-over-presentations-containing-position func child x y))
1706 #+nil
1707 (when (presentationp child)
1708 (funcall func child)))
1709 record
1710 x y)
1711 (when (and (presentationp record)
1712 (presentation-contains-position record x y))
1713 (funcall func record)))
1714
1715 (defvar *null-presentation*)
1716
1717 (defun map-applicable-translators (func
1718 presentation input-context frame window x y
1719 &key event (modifier-state 0)
1720 for-menu
1721 button)
1722 (flet ((process-presentation (context context-ptype presentation)
1723 (let ((maybe-translators
1724 (find-presentation-translators (presentation-type
1725 presentation)
1726 context-ptype
1727 (frame-command-table
1728 frame))))
1729 (loop for translator in maybe-translators
1730 when (and (or (not for-menu) (eql for-menu (menu translator)))
1731 (test-presentation-translator translator
1732 presentation
1733 context-ptype
1734 frame
1735 window
1736 x y
1737 :event event
1738 :modifier-state
1739 modifier-state
1740 :for-menu for-menu
1741 :button button))
1742 do (funcall func translator presentation context)))))
1743 (if (and (presentationp presentation)
1744 (presentation-subtypep (presentation-type presentation)
1745 'blank-area))
1746 (loop for context in input-context
1747 for (context-ptype) = context
1748 do (process-presentation context context-ptype presentation))
1749 (loop for context in input-context
1750 for (context-ptype) = context
1751 do (map-over-presentations-containing-position
1752 #'(lambda (p)
1753 (process-presentation context context-ptype p))
1754 presentation
1755 x y)))))
1756
1757 (defun window-modifier-state (window)
1758 "Provides default modifier state for presentation translator functions."
1759 (let ((pointer (port-pointer (port window))))
1760 (pointer-modifier-state pointer)))
1761
1762 (defun find-applicable-translators
1763 (presentation input-context frame window x y
1764 &key event (modifier-state (window-modifier-state window)) for-menu fastp)
1765 (let ((results nil))
1766 (flet ((fast-func (translator presentation context)
1767 (declare (ignore translator presentation context))
1768 (return-from find-applicable-translators t))
1769 (slow-func (translator presentation context)
1770 (push (list translator presentation (input-context-type context))
1771 results)))
1772 (map-applicable-translators (if fastp #'fast-func #'slow-func)
1773 presentation input-context frame window x y
1774 :event event
1775 :modifier-state modifier-state
1776 :for-menu for-menu)
1777 (nreverse results))))
1778
1779 (defun presentation-matches-context-type
1780 (presentation context-type frame window x y &key event (modifier-state 0))
1781 (let* ((ptype (expand-presentation-type-abbreviation (presentation-type
1782 presentation)))
1783 (ctype (expand-presentation-type-abbreviation context-type))
1784 (translators (find-presentation-translators ptype
1785 ctype
1786 (frame-command-table
1787 frame))))
1788 (loop for translator in translators
1789 if (test-presentation-translator translator
1790 presentation
1791 ctype
1792 frame
1793 window
1794 x y
1795 :event event
1796 :modifier-state modifier-state)
1797 do (return-from presentation-matches-context-type t))
1798 nil))
1799
1800 ;;; 23.7.3 Finding Applicable Presentations
1801
1802 (defun find-innermost-presentation-match
1803 (input-context top-record frame window x y event modifier-state button)
1804 "Helper function that implements the \"innermost-smallest\" input-context
1805 presentation matching algorithm. Returns presentation, translator, and
1806 matching input context."
1807 (let ((result nil)
1808 (result-translator nil)
1809 (result-context nil)
1810 (result-size nil))
1811 (map-applicable-translators
1812 #'(lambda (translator presentation context)
1813 (if (and result-context (not (eq result-context context)))
1814 ;; Return inner presentation
1815 (return-from find-innermost-presentation-match
1816 (values result result-translator result-context))
1817 (multiple-value-bind (min-x min-y max-x max-y)
1818 (output-record-hit-detection-rectangle* presentation)
1819 (let ((size (* (- max-x min-x) (- max-y min-y))))
1820 (when (or (not result) (< size result-size))
1821 (setq result presentation)
1822 (setq result-translator translator)
1823 (setq result-context context)
1824 (setq result-size size))))))
1825 top-record
1826 input-context
1827 frame
1828 window
1829 x y
1830 :event event
1831 :modifier-state modifier-state
1832 :button button)
1833 (when result
1834 (return-from find-innermost-presentation-match
1835 (values result result-translator result-context)))
1836 (map-applicable-translators
1837 #'(lambda (translator presentation context)
1838 (return-from find-innermost-presentation-match
1839 (values presentation translator context)))
1840 *null-presentation*
1841 input-context
1842 frame
1843 window
1844 x y
1845 :event event
1846 :modifier-state modifier-state
1847 :button button))
1848 nil)
1849
1850 (defun find-innermost-applicable-presentation
1851 (input-context window x y
1852 &key (frame *application-frame*)
1853 (modifier-state (window-modifier-state window))
1854 event)
1855 (values (find-innermost-presentation-match input-context
1856 (stream-output-history window)
1857 frame
1858 window
1859 x y
1860 event
1861 modifier-state
1862 nil)))
1863
1864 (defun find-innermost-presentation-context
1865 (input-context window x y
1866 &key (top-record (stream-output-history window))
1867 (frame *application-frame*)
1868 event
1869 (modifier-state (window-modifier-state window))
1870 button)
1871 (find-innermost-presentation-match input-context
1872 top-record
1873 frame
1874 window
1875 x y
1876 event
1877 modifier-state
1878 button))
1879
1880 (defun throw-highlighted-presentation (presentation input-context event)
1881 (let ((x (pointer-event-x event))
1882 (y (pointer-event-y event))
1883 (window (event-sheet event)))
1884 (multiple-value-bind (p translator context)
1885 (find-innermost-presentation-match input-context
1886 presentation
1887 *application-frame*
1888 (event-sheet event)
1889 x y
1890 event
1891 0
1892 nil)
1893 (when p
1894 (multiple-value-bind (object ptype options)
1895 (call-presentation-translator translator
1896 p
1897 (input-context-type context)
1898 *application-frame*
1899 event
1900 window
1901 x y)
1902 (when ptype
1903 (funcall (cdr context) object ptype event options)))))))
1904
1905 (defvar *input-context*)
1906
1907 (defun throw-object-ptype (object type
1908 &key (input-context *input-context*) sheet)
1909 "Throw an object and presentation type within input-context without
1910 a presentation"
1911 (throw-highlighted-presentation
1912 (make-instance 'standard-presentation
1913 :object object :type type
1914 :single-box t)
1915 input-context
1916 (make-instance 'pointer-button-press-event
1917 :sheet sheet
1918 :x 0 :y 0
1919 :modifier-state 0
1920 :button +pointer-left-button+)))
1921
1922 (defstruct presentation-translator-menu-item
1923 translator
1924 presentation
1925 context)
1926
1927 (defun call-presentation-menu
1928 (presentation input-context frame window x y
1929 &key (for-menu t) label)
1930 (let (items)
1931 (map-applicable-translators
1932 #'(lambda (translator presentation context)
1933 (push
1934 `(,(make-presentation-translator-menu-item :translator translator
1935 :presentation presentation
1936 :context context)
1937 :documentation ,(with-output-to-string (stream)
1938 (document-presentation-translator
1939 translator
1940 presentation
1941 input-context
1942 frame nil window x y
1943 :stream stream)))
1944 items))
1945 presentation input-context frame window x y :for-menu for-menu)
1946 (when items
1947 (setq items (nreverse items))
1948 (multiple-value-bind (item object event)
1949 (menu-choose items
1950 :label label
1951 :associated-window window
1952 :printer #'(lambda (item stream)
1953 (let ((object (first item)))
1954 (document-presentation-translator
1955 (presentation-translator-menu-item-translator object)
1956 (presentation-translator-menu-item-presentation object)
1957 (presentation-translator-menu-item-context object)
1958 frame nil window x y
1959 :stream stream)))
1960 :label label
1961 :pointer-documentation *pointer-documentation-output*)
1962 (declare (ignore object))
1963 (when item
1964 (multiple-value-bind (object ptype options)
1965 (call-presentation-translator (presentation-translator-menu-item-translator item)
1966 (presentation-translator-menu-item-presentation item)
1967 (presentation-translator-menu-item-context item)
1968 frame
1969 event
1970 window
1971 x y)
1972 (when ptype
1973 (funcall (cdr (presentation-translator-menu-item-context item)) object ptype event options))))))))
1974
1975 #+nil
1976 (defmethod highlight-output-record ((record standard-presentation)
1977 stream state)
1978 (map-over-output-records
1979 (lambda (child)
1980 (highlight-output-record child stream state))
1981 record))
1982
1983 ;;; Context-dependent input
1984 ;;; An input context is a cons of a presentation type and a continuation to
1985 ;;; call to return a presentation to that input context.
1986
1987 (defvar *input-context* nil)
1988
1989 (defun input-context-type (context-entry)
1990 (car context-entry))
1991
1992 ;;; Many presentation functions, internal and external, take an input
1993 ;;; context as an argument, but they really only need to look at one
1994 ;;; presentation type.
1995 (defun make-fake-input-context (ptype)
1996 (list (cons (expand-presentation-type-abbreviation ptype)
1997 #'(lambda (object type event options)
1998 (declare (ignore event options))
1999 (error "Fake input context called with object ~S type ~S. ~
2000 This shouldn't happen!"
2001 object type)))))
2002
2003 (defun input-context-wait-test (stream)
2004 (let* ((queue (stream-input-buffer stream))
2005 (event (event-queue-peek queue)))
2006 (when event
2007 (let ((sheet (event-sheet event)))
2008 (when (and (output-recording-stream-p sheet)
2009 (or (typep event 'pointer-event)
2010 (typep event 'keyboard-event))
2011 (not (gadgetp sheet)))
2012 (return-from input-context-wait-test t))))
2013 nil))
2014
2015 (defun highlight-applicable-presentation (frame stream input-context
2016 &optional (prefer-pointer-window t))
2017 (let* ((queue (stream-input-buffer stream))
2018 (event (event-queue-peek queue)))
2019 (when (and event
2020 (or (and (typep event 'pointer-event)
2021 (or prefer-pointer-window
2022 (eq stream (event-sheet event))))
2023 (typep event 'keyboard-event)))
2024 ;; Stream only needs to see button press events.
2025 ;; XXX Need to think about this more. Should any pointer events be
2026 ;; passed through? If there's no presentation, maybe?
2027 (unless (typep event 'keyboard-event)
2028 (event-queue-read queue))
2029 (progn
2030 (frame-input-context-track-pointer frame
2031 input-context
2032 (event-sheet event)
2033 event)
2034 (when (typep event 'pointer-button-press-event)
2035 (funcall *pointer-button-press-handler* stream event)))
2036 #+nil
2037 (if (and (typep event 'pointer-motion-event)
2038 (pointer-event-button event))
2039 (frame-drag frame input-context (event-sheet event) event)
2040 ))))
2041
2042 (defun input-context-event-handler (stream)
2043 (highlight-applicable-presentation *application-frame*
2044 stream
2045 *input-context*))
2046
2047 (defun input-context-button-press-handler (stream button-event)
2048 (declare (ignore stream))
2049 (frame-input-context-button-press-handler *application-frame*
2050 (event-sheet button-event)
2051 button-event))
2052
2053 (defun highlight-current-presentation (frame input-context)
2054 (let ((event (synthesize-pointer-motion-event (port-pointer
2055 (port
2056 *application-frame*)))))
2057 (when event
2058 (frame-input-context-track-pointer frame
2059 input-context
2060 (event-sheet event)
2061 event))))
2062
2063 (defmacro with-input-context ((type &key override)
2064 (&optional (object-var (gensym))
2065 (type-var (gensym))
2066 event-var
2067 options-var)
2068 form
2069 &body pointer-cases)
2070 (let ((vars `(,object-var
2071 ,type-var
2072 ,@(and event-var `(,event-var))
2073 ,@(and options-var `(,options-var))))
2074 (return-block (gensym "RETURN-BLOCK"))
2075 (context-block (gensym "CONTEXT-BLOCK")))
2076 `(block ,return-block
2077 (multiple-value-bind ,vars
2078 (block ,context-block
2079 (let ((*input-context*
2080 (cons (cons (expand-presentation-type-abbreviation ,type)
2081 #'(lambda (object type event options)
2082 (return-from ,context-block
2083 (values object type event options))))
2084 ,(if override nil '*input-context*)))
2085 (*pointer-button-press-handler*
2086 #'input-context-button-press-handler)
2087 (*input-wait-test* #'input-context-wait-test)
2088 (*input-wait-handler* #'input-context-event-handler))
2089 (return-from ,return-block ,form )))
2090 (declare (ignorable ,@vars))
2091 (highlight-current-presentation *application-frame* *input-context*)
2092 (cond ,@(mapcar #'(lambda (pointer-case)
2093 (destructuring-bind (case-type &body case-body)
2094 pointer-case
2095 `((presentation-subtypep ,type-var ',case-type)
2096 ,@case-body)))
2097 pointer-cases))))))

  ViewVC Help
Powered by ViewVC 1.1.5