[mcclim-cvs] CVS update: mcclim/presentations.lisp mcclim/presentation-defs.lisp mcclim/dialog.lisp mcclim/views.lisp
Timothy Moore
tmoore at common-lisp.net
Tue Jan 11 13:02:32 UTC 2005
Update of /project/mcclim/cvsroot/mcclim
In directory common-lisp.net:/tmp/cvs-serv14709
Modified Files:
presentations.lisp presentation-defs.lisp dialog.lisp
views.lisp
Log Message:
Implement :SINGLE-BOX properly.:SINGLE-BOX NIL is the default, but
McCLIM has ignored it. This changes (for the better) the behavior of
applications.
Implement PRESENTATION-REFINED-POSITION-TEST.
If the view argument to ACCEPT is a list, apply MAKE-INSTANCE to the
list to obtain the view.
Fix a bug in dialogs that prevented moving on to the next text field
after hitting return.
Define a new view type, TEXT-FIELD-VIEW, that is used in
dialogs. This view has a WIDTH parameter.
Date: Tue Jan 11 14:02:29 2005
Author: tmoore
Index: mcclim/presentations.lisp
diff -u mcclim/presentations.lisp:1.68 mcclim/presentations.lisp:1.69
--- mcclim/presentations.lisp:1.68 Sun Nov 7 20:33:31 2004
+++ mcclim/presentations.lisp Tue Jan 11 14:02:19 2005
@@ -1107,7 +1107,8 @@
, at lambda-list)
(declare (ignorable ,(type-key-arg gf))
,@(cdr decls))
- , at body))))
+ (block ,name
+ , at body)))))
;;; Somewhat obsolete, but keep it around for apply-presentation-generic-function.
(defun %funcall-presentation-generic-function (name gf type-arg-position
@@ -1283,6 +1284,10 @@
&allow-other-keys)
arglist
&body body)
+ ;; null tester should be the same as no tester
+ (unless tester
+ (setq tester 'default-translator-tester)
+ (setq tester-definitive t))
(let* ((real-from-type (expand-presentation-type-abbreviation from-type))
(real-to-type (expand-presentation-type-abbreviation to-type)))
(with-keywords-removed (translator-options
@@ -1586,15 +1591,7 @@
t)
-(defun presentation-contains-position (record x y)
- (let ((single-box (presentation-single-box record)))
- (multiple-value-bind (min-x min-y max-x max-y)
- (output-record-hit-detection-rectangle* record)
- (if (and (<= min-x x max-x) (<= min-y y max-y))
- (if (or (null single-box) (eq single-box :higlighting))
- (output-record-refined-position-test record x y)
- t)
- nil))))
+;;; presentation-contains-position moved to presentation-defs.lisp
(defun map-over-presentations-containing-position (func record x y)
"maps recursively over all presentations in record, including record."
@@ -1799,7 +1796,8 @@
a presentation"
(throw-highlighted-presentation
(make-instance 'standard-presentation
- :object object :type type)
+ :object object :type type
+ :single-box t)
input-context
(make-instance 'pointer-button-press-event
:sheet sheet
Index: mcclim/presentation-defs.lisp
diff -u mcclim/presentation-defs.lisp:1.38 mcclim/presentation-defs.lisp:1.39
--- mcclim/presentation-defs.lisp:1.38 Sun Jan 2 06:28:38 2005
+++ mcclim/presentation-defs.lisp Tue Jan 11 14:02:19 2005
@@ -647,7 +647,7 @@
(defun accept (type &rest rest-args &key
(stream *standard-input*)
- view
+ (view nil viewp)
(default nil defaultp)
(default-type nil default-type-p)
provide-default insert-default replace-input
@@ -680,6 +680,12 @@
(list* :default-type real-default-type rest-args)))
(when historyp
(setf rest-args (list* :history real-history-type rest-args)))
+ (cond ((and viewp (symbolp view))
+ (setf rest-args
+ (list* :view (funcall #'make-instance view) rest-args)))
+ ((consp view)
+ (setf rest-args
+ (list* :view (apply #'make-instance view) rest-args))))
;; Presentation type history interaction. According to the spec,
;; if provide-default is true, we take the default from the
;; presentation history. In addition, we'll implement the Genera
@@ -929,6 +935,40 @@
(with-input-from-string (stream string :start start :end end)
(with-keywords-removed (args (:start :end))
(apply #'stream-accept stream type :view +textual-view+ args))))
+
+(define-presentation-generic-function %presentation-refined-position-test
+ presentation-refined-position-test
+ (type-key parameters options type record x y))
+
+(define-default-presentation-method presentation-refined-position-test
+ (type record x y)
+ (declare (ignore type))
+ ;;; output-record-hit-detection-rectangle* has already been called
+ (let ((single-box (presentation-single-box record)))
+ (if (or (eq single-box t) (eq single-box :position))
+ t
+ (labels ((tester (record)
+ (typecase record
+ (displayed-output-record
+ (return-from presentation-refined-position-test t))
+ (compound-output-record
+ (map-over-output-records-containing-position
+ #'tester record x y))
+ (t nil))))
+ (tester record)
+ nil))))
+
+(defun presentation-contains-position (record x y)
+ (let ((single-box (presentation-single-box record)))
+ (multiple-value-bind (min-x min-y max-x max-y)
+ (output-record-hit-detection-rectangle* record)
+ (if (and (<= min-x x max-x) (<= min-y y max-y))
+ (if (or (null single-box) (eq single-box :higlighting))
+ (funcall-presentation-generic-function
+ presentation-refined-position-test
+ (presentation-type record) record x y)
+ t)
+ nil))))
(define-presentation-generic-function %highlight-presentation
highlight-presentation
Index: mcclim/dialog.lisp
diff -u mcclim/dialog.lisp:1.15 mcclim/dialog.lisp:1.16
--- mcclim/dialog.lisp:1.15 Sun Jan 2 06:24:49 2005
+++ mcclim/dialog.lisp Tue Jan 11 14:02:19 2005
@@ -318,11 +318,12 @@
(when query
(setf selected-query query)
(select-query *accepting-values-stream* query (record query))
- (if (cdr query-list)
- (throw-object-ptype (query-identifier (cadr query-list))
- 'selectable-query)
- (throw-object-ptype '(com-deselect-query)
- '(command :command-table accepting-values))))))))
+ (let ((command-ptype '(command :command-table accepting-values)))
+ (if (cdr query-list)
+ (throw-object-ptype `(com-select-query ,(query-identifier
+ (cadr query-list)))
+ command-ptype)
+ (throw-object-ptype '(com-deselect-query) command-ptype))))))))
(define-command (com-deselect-query :command-table accepting-values
:name nil
@@ -344,6 +345,24 @@
is called. Used to determine if any editing has been done by user")))
(defparameter *no-default-cache-value* (cons nil nil))
+
+;;; Hack until more views / dialog gadgets are defined.
+
+(define-default-presentation-method accept-present-default
+ (type stream (view text-field-view) default default-supplied-p
+ present-p query-identifier)
+ (if (width view)
+ (multiple-value-bind (cx cy)
+ (stream-cursor-position stream)
+ (declare (ignore cy))
+ (letf (((stream-text-margin stream) (+ cx (width view))))
+ (funcall-presentation-generic-function accept-present-default
+ type
+ stream
+ +textual-dialog-view+
+ default default-supplied-p
+ present-p
+ query-identifier)))))
(define-default-presentation-method accept-present-default
(type stream (view textual-dialog-view) default default-supplied-p
Index: mcclim/views.lisp
diff -u mcclim/views.lisp:1.5 mcclim/views.lisp:1.6
--- mcclim/views.lisp:1.5 Mon Nov 3 09:12:35 2003
+++ mcclim/views.lisp Tue Jan 11 14:02:19 2005
@@ -44,6 +44,11 @@
(defclass pointer-documentation-view (textual-view)
())
+;;; Views described in the Franz User manual...
+
+(defclass text-field-view (gadget-dialog-view)
+ ((width :accessor width :initarg :width :initform nil)))
+
(defparameter +textual-view+ (make-instance 'textual-view))
(defparameter +textual-menu-view+ (make-instance 'textual-menu-view))
@@ -58,6 +63,8 @@
(defparameter +pointer-documentation-view+
(make-instance 'pointer-documentation-view))
+
+(defparameter +text-field-view+ (make-instance 'text-field-view))
(defmethod stream-default-view (stream)
(declare (ignore stream))
More information about the Mcclim-cvs
mailing list