[mcclim-cvs] CVS mcclim
crhodes
crhodes at common-lisp.net
Wed Jan 10 11:19:01 UTC 2007
Update of /project/mcclim/cvsroot/mcclim
In directory clnet:/tmp/cvs-serv25795
Modified Files:
builtin-commands.lisp presentations.lisp
presentation-defs.lisp
Log Message:
Mostly fix AND and OR presentation types in STUPID-SUBTYPEP (used for
translator applicability) and PRESENTATION-SUBTYPEP. Add some tests for
predefined presentation types.
--- /project/mcclim/cvsroot/mcclim/builtin-commands.lisp 2006/11/08 01:18:22 1.25
+++ /project/mcclim/cvsroot/mcclim/builtin-commands.lisp 2007/01/10 11:19:01 1.26
@@ -93,9 +93,15 @@
(t nil global-command-table
:gesture :select
:tester ((presentation context-type)
- (presentation-subtypep (presentation-type presentation)
- context-type))
- :tester-definitive t
+ ;; see the comments around DEFUN PRESENTATION-SUBTYPEP
+ ;; for some of the logic behind this. Only when
+ ;; PRESENTATION-SUBTYPEP is unsure do we test the object
+ ;; itself for PRESENTATION-TYPEP.
+ (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 +122,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
--- /project/mcclim/cvsroot/mcclim/presentations.lisp 2006/12/13 19:35:01 1.78
+++ /project/mcclim/cvsroot/mcclim/presentations.lisp 2007/01/10 11:19:01 1.79
@@ -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))
--- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2007/01/09 03:39:09 1.67
+++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2007/01/10 11:19:01 1.68
@@ -162,31 +162,126 @@
(block presentation-subtypep
, at body))))))))
+;;; PRESENTATION-SUBTYPEP suffers from some of the same problems as
+;;; CL:SUBTYPEP, most (but sadly not all) of which were solved in
+;;; H. Baker "A Decision Procedure for SUBTYPEP"; additionally, it
+;;; suffers from the behaviour being underspecified, as CLIM
+;;; documentation did not have the years of polish that CLtS did.
+;;;
+;;; So you might wonder why, instead of copying or using directly some
+;;; decent Public Domain subtype code (such as that found in SBCL,
+;;; implementing CL:SUBTYPEP), there's this slightly wonky
+;;; implementation here. Well, some of the answer lies in the fact
+;;; that the subtype relationships answered by this predicate are not
+;;; in fact analogous to CL's type system. The major use of
+;;; PRESENTATION-SUBTYPEP seems to be for determining whether a
+;;; presentation is applicable as input to a translator (including the
+;;; default translator, transforming an object to itself); actually,
+;;; the first step is taken by STUPID-SUBTYPEP, but that I believe is
+;;; simply intended to be a short-circuiting conservative version of
+;;; PRESENTATION-SUBTYPEP.
+;;;
+;;; Most presentation types in CLIM are hierarchically arranged by
+;;; single-inheritance, and SUBTYPEP relations on the hierarchy are
+;;; easy to determine: simply walk up the hierarchy until you find the
+;;; putative supertype (in which case the answer is T, T unless the
+;;; type's parameters are wrong) or you find the universal supertype
+;;; (in which case the answer is NIL, T. There are numerous wrinkles,
+;;; however...
+;;;
+;;; (1) the NIL presentation type is the universal subtype, breaking
+;;; the single-inheritance of the hierarchy. This isn't too bad,
+;;; because it can be special-cased.
+;;;
+;;; (2) union types can be constructed, destroying the
+;;; single-inheritance hierarchy (when used as a subtype).
+;;;
+;;; (3) union types can give rise to ambiguity. For example, is the
+;;; NUMBER presentation type subtypep (OR REAL COMPLEX)? What
+;;; about (INTEGER 3 6) subtypep (OR (INTEGER 3 4) (INTEGER 5 6))?
+;;; Is (OR A B) subtypep (OR B A)? The answer to this last
+;;; question is not obvious, as the two types have different
+;;; ACCEPT behaviour if A and B have any Lisp objects in common,
+;;; even if the presentation types are hierarchically unrelated...
+;;;
+;;; (4) intersection types can be constructed, destroying the
+;;; single-inheritance hierarchy (when used as a supertype). This
+;;; is partially mitigated by the explicit documentation that the
+;;; first type in the AND type's parameters is privileged and
+;;; treated specially by ACCEPT.
+;;;
+;;; Given these difficulties, I'm aiming for roughly expected
+;;; behaviour from STUPID- and PRESENTATION-SUBTYPEP, rather than
+;;; something which has a comprehensive understanding of presentation
+;;; types and the Lisp object universe (as this would be unachievable
+;;; anyway: the user can write arbitrary PRESENTATION-TYPEP
+;;; functions); PRESENTATION-SUBTYPEP should not be thought of as a
+;;; predicate over sets of Lisp objects, but simply a formal predicate
+;;; over a graph of names. This gives rise to the implementation
+;;; below for OR and AND types, and the hierarchical walk for all
+;;; other types. CSR, 2007-01-10
(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)
+ (assert (not (eq type-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)
+ (assert (not (eq super-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)
@@ -2172,18 +2267,14 @@
:acceptably acceptably
:for-context-type for-context-type))
-(define-presentation-method accept ((type and)
- (stream input-editing-stream)
- (view textual-view)
- &key)
- (let* ((subtype (first types))
- (value (accept subtype
- :stream stream
- :view view
- :prompt nil)))
- (unless (presentation-typep value type)
- (simple-parse-error "Input type is not of type ~S" type))
- value))
+(define-presentation-method accept
+ ((type and) (stream input-editing-stream) (view textual-view) &rest args &key)
+ (let ((subtype (first types)))
+ (multiple-value-bind (obj ptype)
+ (apply-presentation-generic-function accept subtype stream view args)
+ (unless (presentation-typep obj type)
+ (simple-parse-error "Input object ~S is not of type ~S" obj type))
+ obj)))
(define-presentation-type-abbreviation token-or-type (tokens type)
`(or (member-alist ,tokens) ,type))
More information about the Mcclim-cvs
mailing list