[mcclim-devel] presentation-subtypep
Christophe Rhodes
csr21 at cantab.net
Tue Jan 9 09:32:14 EST 2007
Robert Goldman <rpgoldman at real-time.com> writes:
> With Xof's help, I have butchered the definition of
> presentation-subtypep in McCLIM to hand AND types --- previously it only
> handled OR. Here is a draft new defun (apologies is wrapper gonks it)
> and, for those who prefer, I will attach (unless I forget again) a patch
> file:
I think that the attached is better, but it still is not perfect. (I
will commit it unless I hear screams of pain, though). It comes in
two parts (plus some tests):
* modifications to PRESENTATION-SUBTYPEP and STUPID-SUBTYPEP to handle
most cases of AND and OR presentation types. Some of the cases are
about as good as we can get; there's room for improvement in others.
There are a few surprises lurking in the definitions of presentation
types and their relationships: they don't correspond directly to CL
types, so some of the instincts about those are misleading; AND
types are somewhat special, in that the first parameter of an AND
type is magical.
* a modification to DEFAULT-TRANSLATOR to try to get the right
behaviour for complicated presentation types. It's not quite right,
but actually I think that to get it completely right involves
solving SATISFIABILITY, which isn't in my gameplan.
This seems to mostly work; the test file which is included in the
attached diff passes. A further test at the listener is
(present "abc" 'string)
(present "def" 'string)
(defun foop (x)
(char= (char x 0) #\a))
(with-input-context ('(and string (satisfies foop))) (obj otype ev opts)
(loop (read-char))
(t obj))
which makes only the "abc" string and not the "def" string mousable.
Unfortunately, (accept '(and string (satisfies foop))) doesn't work as
expected, as the accept method for AND establishes an inner
input-context for STRING, which means that the "def" string is
mousable (and causes an error if you click on it).
Would something like
(define-presentation-method accept
((type and) (stream input-editing-stream) (view textual-view) &key)
(let ((subtype (first types)))
(multiple-value-bind (ob ty)
(funcall-presentation-generic-function accept subtype stream view)
(unless (presentation-typep ob type)
(simple-parse-error "Object ~S is not of type ~S" ob type))
value)))
be acceptable (haha)? It seems to work for me, in that after I define
this (accept '(and string (satisfies foop))) makes only the strings
beginning with #\a mousable, but I don't know how to handle the
keyword arguments (or even if they've already been handled by stuff up
the stack).
-------------- next part --------------
Index: builtin-commands.lisp
===================================================================
RCS file: /project/mcclim/cvsroot/mcclim/builtin-commands.lisp,v
retrieving revision 1.25
diff -u -r1.25 builtin-commands.lisp
--- builtin-commands.lisp 8 Nov 2006 01:18:22 -0000 1.25
+++ builtin-commands.lisp 9 Jan 2007 14:10:31 -0000
@@ -93,9 +93,19 @@
(t nil global-command-table
:gesture :select
:tester ((presentation context-type)
- (presentation-subtypep (presentation-type presentation)
- context-type))
- :tester-definitive t
+ ;; This is an approximation; I think the question we
+ ;; should really be asking is "do the presentation and
+ ;; context-type intersect?", which we could do by asking
+ ;; (presentation-subtypep `(and ,ptype ,ctype) nil).
+ ;; However, in practice, this would always return NIL,
+ ;; NIL, not helping at all. So instead we reject
+ ;; presentations with types that are definitely not
+ ;; subtypes of the context-type.
+ (multiple-value-bind (yp sp)
+ (presentation-subtypep (presentation-type presentation)
+ context-type)
+ (or yp (not sp))))
+ :tester-definitive nil
:menu nil
:documentation ((object presentation context-type frame event window x y stream)
(let* ((type (presentation-type presentation))
@@ -116,6 +126,10 @@
:stream stream
:sensitive nil)))))
(object presentation)
+ ;; returning (PRESENTATION-TYPE PRESENTATION) as the ptype is
+ ;; formally undefined, as this means that the translator returns a
+ ;; presentation type which is not PRESENTATION-SUBTYPEP the
+ ;; translator's TO-TYPE.
(values object (presentation-type presentation)))
(define-presentation-action presentation-menu
Index: presentation-defs.lisp
===================================================================
RCS file: /project/mcclim/cvsroot/mcclim/presentation-defs.lisp,v
retrieving revision 1.67
diff -u -r1.67 presentation-defs.lisp
--- presentation-defs.lisp 9 Jan 2007 03:39:09 -0000 1.67
+++ presentation-defs.lisp 9 Jan 2007 14:10:32 -0000
@@ -163,30 +163,65 @@
, at body))))))))
(defun presentation-subtypep (type maybe-supertype)
- (when (equal type maybe-supertype)
+ ;; special shortcuts: the universal subtype is privileged (and
+ ;; doesn't in fact fit into a hierarchical lattice); the universal
+ ;; supertype is easy to identify.
+ (when (or (eql type nil) (eql maybe-supertype t))
+ (return-from presentation-subtypep (values t t)))
+ (when (eql type maybe-supertype)
(return-from presentation-subtypep (values t t)))
(with-presentation-type-decoded (super-name super-parameters)
- maybe-supertype
- (when (eq super-name 'or)
- (loop for or-type in super-parameters
- when (presentation-subtypep type or-type)
- do (return-from presentation-subtypep (values t t))
- finally (return-from presentation-subtypep (values nil t))))
- (when (eq super-name 'satisfies)
- (return-from presentation-subtypep (values nil nil)))
- (with-presentation-type-decoded (sub-name sub-parameters)
- type
- (when (eq sub-name 'and)
- (loop for and-type in sub-parameters
- with subtypep and knownp
- with answer-knownp = t
- do (multiple-value-setq (subtypep knownp)
- (presentation-subtypep and-type maybe-supertype))
- if subtypep
- do (return-from presentation-subtypep (values t t))
- else ; track whether we know the answer
- do (setf answer-knownp (and answer-knownp knownp))
- finally (return-from presentation-subtypep (values nil answer-knownp)))))
+ maybe-supertype
+ (with-presentation-type-decoded (type-name type-parameters)
+ type
+ (cond
+ ;; DO NOT BE TEMPTED TO REARRANGE THESE CLAUSES
+ ((eq type-name 'or)
+ (dolist (or-type type-parameters
+ (return-from presentation-subtypep (values t t)))
+ (multiple-value-bind (yesp surep)
+ (presentation-subtypep or-type maybe-supertype)
+ (unless yesp
+ (return-from presentation-subtypep (values yesp surep))))))
+ ((eq super-name 'and)
+ (let ((result t))
+ (dolist (and-type super-parameters
+ (return-from presentation-subtypep (values result result)))
+ (cond
+ ((and (consp and-type) (eq (car and-type) 'satisfies))
+ (setq result nil))
+ ((and (consp and-type) (eq (car and-type) 'not))
+ (multiple-value-bind (yp sp)
+ (presentation-subtypep type (cadr and-type))
+ (if yp
+ (return-from presentation-subtypep (values nil t))
+ (setq result nil))))
+ (t (multiple-value-bind (yp sp)
+ (presentation-subtypep type and-type)
+ (unless yp
+ (if sp
+ (return-from presentation-subtypep (values nil t))
+ (setq result nil)))))))))
+ ((eq super-name 'or)
+ ;; FIXME: this would be the right method were it not for the
+ ;; fact that there can be unions 'in disguise' in the
+ ;; subtype; examples:
+ ;; (PRESENTATION-SUBTYPEP 'NUMBER '(OR REAL COMPLEX))
+ ;; (PRESENTATION-SUBTYPEP '(INTEGER 3 6)
+ ;; '(OR (INTEGER 2 5) (INTEGER 4 7)))
+ ;; Sorry about that.
+ (let ((surep t))
+ (dolist (or-type super-parameters
+ (return-from presentation-subtypep (values nil surep)))
+ (multiple-value-bind (yp sp)
+ (presentation-subtypep type or-type)
+ (cond
+ (yp (return-from presentation-subtypep (values t t)))
+ ((not sp) (setq surep nil)))))))
+ ((eq type-name 'and)
+ (multiple-value-bind (yp sp)
+ (presentation-subtypep (car type-parameters) maybe-supertype)
+ (return-from presentation-subtypep (values yp yp))))))
(map-over-presentation-type-supertypes
#'(lambda (name massaged)
(when (eq name super-name)
Index: presentations.lisp
===================================================================
RCS file: /project/mcclim/cvsroot/mcclim/presentations.lisp,v
retrieving revision 1.78
diff -u -r1.78 presentations.lisp
--- presentations.lisp 13 Dec 2006 19:35:01 -0000 1.78
+++ presentations.lisp 9 Jan 2007 14:10:32 -0000
@@ -1419,30 +1419,50 @@
(eq super-meta *standard-object-class*))))
do (funcall function super-meta))))
+;;; This is to implement the requirement on presentation translators
+;;; for doing subtype calculations without reference to type
+;;; parameters. We are generous in that we return T when we are
+;;; unsure, to give translator testers a chance to accept or reject
+;;; the translator. This is essentially
+;;; (multiple-value-bind (yesp surep)
+;;; (presentation-subtypep maybe-subtype type)
+;;; (or yesp (not surep)))
+;;; except faster.
(defun stupid-subtypep (maybe-subtype type)
"Return t if maybe-subtype is a presentation subtype of type, regardless of
parameters."
- (when (or (eq maybe-subtype nil)
- (eq type t)
- (equal maybe-subtype type))
+ (when (or (eq maybe-subtype nil) (eq type t))
+ (return-from stupid-subtypep t))
+ (when (eql maybe-subtype type)
(return-from stupid-subtypep t))
(let ((maybe-subtype-name (presentation-type-name maybe-subtype))
(type-name (presentation-type-name type)))
- (when (eq type-name 'or)
- (loop for or-type in (decode-parameters type)
- when (stupid-subtypep maybe-subtype or-type)
- do (return-from stupid-subtypep t)
- finally (return-from stupid-subtypep nil)))
- (let ((subtype-meta (get-ptype-metaclass maybe-subtype-name))
- (type-meta (get-ptype-metaclass type-name)))
- (unless (and subtype-meta type-meta)
- (return-from stupid-subtypep nil))
- (map-over-ptype-superclasses #'(lambda (super)
- (when (eq type-meta super)
- (return-from stupid-subtypep t)))
- maybe-subtype-name)
- nil)))
-
+ (cond
+ ;; see DEFUN PRESENTATION-SUBTYPEP for some caveats
+ ((eq maybe-subtype-name 'or)
+ (let ((or-types (decode-parameters maybe-subtype)))
+ (every (lambda (x) (stupid-subtypep x type)) or-types)))
+ ((eq type-name 'and)
+ (stupid-subtypep maybe-subtype (car (decode-parameters type))))
+ ((eq type-name 'or)
+ (let ((or-types (decode-parameters type)))
+ (some (lambda (x) (stupid-subtypep maybe-subtype x)) or-types)))
+ ((eq maybe-subtype-name 'and)
+ ;; this clause is actually not conservative, but probably in a
+ ;; way that no-one will complain about too much. Basically, we
+ ;; will only return T if the first type in the AND (which is
+ ;; treated specially by CLIM) is subtypep the maybe-supertype
+ (stupid-subtypep (car (decode-parameters maybe-subtype)) type))
+ (t
+ (let ((subtype-meta (get-ptype-metaclass maybe-subtype-name))
+ (type-meta (get-ptype-metaclass type-name)))
+ (unless (and subtype-meta type-meta)
+ (return-from stupid-subtypep nil))
+ (map-over-ptype-superclasses #'(lambda (super)
+ (when (eq type-meta super)
+ (return-from stupid-subtypep t)))
+ maybe-subtype-name)
+ nil)))))
(defun find-presentation-translators (from-type to-type command-table)
(let* ((command-table (find-command-table command-table))
Index: Tests/presentation-types.lisp
===================================================================
RCS file: Tests/presentation-types.lisp
diff -N Tests/presentation-types.lisp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Tests/presentation-types.lisp 9 Jan 2007 14:10:32 -0000
@@ -0,0 +1,97 @@
+(in-package :clim-tests)
+
+(defparameter *presentation-type-supertypes*
+ '(;; 23.8.1
+ (t)
+ ;; NIL is a special case
+ (null t) (boolean t) (symbol t) (keyword symbol t) (blank-area t)
+ ;; 23.8.2
+ (number t) (complex number t) (real number t) (rational real number t)
+ (integer rational real number t) (ratio rational real number t)
+ (float real number t)
+ ;; 23.8.3
+ (character t) (string t)
+ ;; 23.8.4
+ (pathname t)
+ ;; 23.8.5
+ ((completion nil) t)
+ ;; not allowed abbreviations
+ ;; (member t) ((member-sequence nil) t) ((member-alist nil) t)
+ ((subset-completion nil) t)
+ ;; (subset t) ((subset-sequence nil) t) ((subset-alist nil) t)
+ ;; 23.8.6
+ ((sequence t) t) (sequence-enumerated t)
+ ;; 23.8.7
+ ;; OR, AND
+ ;; 23.8.8
+ ;; ((token-or-type nil t) t) ((null-or-type t) t) ((type-or-string t) t)
+ ;; 23.8.9
+ (expression t)
+ (form expression t)))
+
+(defun expect-t-t (type supertype)
+ (multiple-value-bind (yesp surep)
+ (presentation-subtypep type supertype)
+ (assert yesp)
+ (assert surep))
+ #+mcclim
+ ;; we can do this because *presentation-type-supertypes* doesn't do
+ ;; clever things with type parameters
+ (assert (climi::stupid-subtypep type supertype)))
+
+(defun expect-nil-t (type supertype)
+ (multiple-value-bind (yesp surep)
+ (presentation-subtypep type supertype)
+ (assert (not yesp))
+ (assert surep))
+ #+mcclim
+ (assert (not (climi::stupid-subtypep type supertype))))
+
+(defun expect-nil-nil (type supertype)
+ (multiple-value-bind (yesp surep)
+ (presentation-subtypep type supertype)
+ (assert (not yesp))
+ (assert (not surep)))
+ ;; stupid-subtypep must be conservative in what it reports as
+ ;; possibly acceptable.
+ #+mcclim
+ (assert (climi::stupid-subtypep type supertype)))
+
+(loop for (type . supertypes) in *presentation-type-supertypes*
+ do (expect-t-t type type)
+ do (expect-t-t nil type)
+ ;; if presentation types were "real" (FIXME: work out what
+ ;; "real" means) types, then this wouldn't actually be true.
+ ;; However, PRESENTATION-SUBTYPEP works by walking up the type
+ ;; lattice until it finds a match, and only then checks the type
+ ;; parameters. So even though presentation types (or
+ ;; abbreviations) like (MEMBER) actually denote the empty set,
+ ;; they are not PRESENTATION-SUBTYPEP NIL.
+ do (expect-nil-t type nil)
+ do (mapcar (lambda (x) (expect-t-t type x)) supertypes))
+
+(loop for (type) in *presentation-type-supertypes*
+ do (expect-t-t type `(and ,type))
+ do (expect-t-t `(and ,type) type)
+ do (expect-t-t `(and ,type) `(and ,type))
+ do (expect-t-t type `(or ,type))
+ do (expect-t-t `(or ,type) type)
+ do (expect-t-t `(or ,type) `(or ,type))
+ do (expect-t-t `(or ,type) `(and ,type))
+ do (expect-t-t `(and ,type) `(or ,type)))
+
+(defun constantly-t (object)
+ (declare (ignore object))
+ t)
+
+(loop for (type) in *presentation-type-supertypes*
+ do (expect-t-t `(and ,type (satisfies constantly-t)) type)
+ do (expect-nil-nil type `(and ,type (satisfies constantly-t)))
+ do (expect-t-t `(and ,type (not nil)) type)
+ do (expect-nil-nil type `(and ,type (not nil))))
+
+(expect-t-t '(or integer symbol) '(or integer symbol))
+(expect-t-t '(or integer symbol) '(or symbol integer))
+
+(expect-t-t '(or real complex) 'number)
+#+nil (expect-t-t 'number '(or real complex))
-------------- next part --------------
Cheers,
Christophe
More information about the mcclim-devel
mailing list