Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv16423 Modified Files: dialog.lisp incremental-redisplay.lisp input-editing.lisp presentation-defs.lisp stream-input.lisp Log Message: Fixed presentation highlighting to do the right thing in the :SINGLE-BOX NIL case. Fixed Goatee to not draw anything when drawing is not enabled for the stream. Changed input editing streams to never put activation gestures in the input buffer. There is only one place to receive an activation gesture: the end of the buffer. If the user types an activation gesture, the insertion pointer is moved to the end of the buffer. Fixed various problems with accepting-values. In particular, the insertion pointer does not need to be left at the end of a field when the user exits the dialog. Also, the behavior in the presence of errors new: if an error occurs while the user is typing in an accepting-values field, the bell is beeped and the insertion pointer is positioned before the stream position where the error occured. Date: Tue Feb 22 15:00:11 2005 Author: tmoore Index: mcclim/dialog.lisp diff -u mcclim/dialog.lisp:1.17 mcclim/dialog.lisp:1.18 --- mcclim/dialog.lisp:1.17 Tue Jan 18 11:58:08 2005 +++ mcclim/dialog.lisp Tue Feb 22 15:00:10 2005 @@ -102,7 +102,11 @@ ((queries :accessor queries :initform nil) (selected-query :accessor selected-query :initform nil) (align-prompts :accessor align-prompts :initarg :align-prompts - :initform nil))) + :initform nil) + (last-pass :accessor last-pass :initform nil + :documentation "Flag that indicates the last pass through the + body of ACCEPTING-VALUES, after the user has chosen to exit. This controls + when conditions will be signalled from calls to ACCEPT."))) (defmethod stream-default-view ((stream accepting-values-stream)) +textual-dialog-view+) @@ -206,6 +210,7 @@ (redisplay arecord stream)) (av-exit () (finalize-query-records *accepting-values-stream*) + (setf (last-pass *accepting-values-stream*) t) (redisplay arecord stream))) (erase-output-record arecord stream) (setf (stream-cursor-position stream) @@ -283,7 +288,7 @@ (do-prompt) (setq query-record (do-accept-present-default)))) (setf (record query) query-record) - (when (accept-condition query) + (when (and (last-pass stream) (accept-condition query)) (signal (accept-condition query))) (multiple-value-prog1 (values (value query) (ptype query) (changedp query)) @@ -344,8 +349,7 @@ :key #'query-identifier :test #'equal)) (query (car query-list))) (when selected-query - (unless (equal query-identifier - (query-identifier selected-query)) + (unless (equal query-identifier (query-identifier selected-query)) (deselect-query *accepting-values-stream* selected-query (record selected-query)))) @@ -409,7 +413,8 @@ *no-default-cache-value*) :record-type 'av-text-record) (with-output-as-presentation - (stream query-identifier 'selectable-query) + (stream query-identifier 'selectable-query + :single-box t) (surrounding-output-with-border (stream :shape :inset :move-cursor t) (setq editing-stream @@ -429,23 +434,62 @@ (setf (editing-stream record) editing-stream)) record)) -(defun av-do-accept (query record) - (let ((estream (editing-stream record)) - (ptype (ptype query)) - (view (view query)) - (default (default query)) - (default-supplied-p (default-supplied-p query))) - (setf (values (value query) (ptype query)) ; Hmm, should ptype be set here? - (input-editing-rescan-loop - estream - (if default-supplied-p - ;; Allow empty input to return a default value - #'(lambda (s) - (accept ptype :stream s :view view :prompt nil - :default default)) - #'(lambda (s) - (accept ptype :stream s :view view :prompt nil))))) - (setf (changedp query) t))) +(defun av-do-accept (query record interactive) + (let* ((estream (editing-stream record)) + (ptype (ptype query)) + (view (view query)) + (default (default query)) + (default-supplied-p (default-supplied-p query)) + (accept-args (accept-arguments query)) + (*activation-gestures* (apply #'make-activation-gestures + :existing-activation-gestures + (activation-gestures query) + accept-args)) + (*delimiter-gestures* (apply #'make-delimiter-gestures + :existing-delimiter-args + (delimiter-gestures query) + accept-args))) + ;; If there was an error on a previous pass, set the insertion pointer to + ;; 0 so the user has a chance to edit the field without causing another + ;; error. Otherwise the insertion pointer should already be at the end of + ;; the input (because it was activated); perhaps we should set it anyway. + (when (accept-condition query) + (setf (stream-insertion-pointer estream) 0)) + (reset-scan-pointer estream) + (setf (accept-condition query) nil) + ;; If a condition is thrown, then accept should return the old value and + ;; ptype. + (block accept-condition-handler + (setf (changedp query) nil) + (setf (values (value query) (ptype query)) + (input-editing-rescan-loop + estream + #'(lambda (s) + (handler-bind + ((error + #'(lambda (c) + (format *trace-output* + "accepting-values accept condition: ~A~%" + c) + (if interactive + (progn + (beep) + (goatee::set-editing-stream-insertion-pointer + estream + (1- (stream-scan-pointer estream))) + (immediate-rescan estream) + (format *trace-output* "Ack!~%")) + (progn + (setf (accept-condition query) c) + (return-from accept-condition-handler + c)))))) + (goatee::update-input-editing-stream s) + (if default-supplied-p + (accept ptype :stream s + :view view :prompt nil :default default) + (accept ptype :stream s :view view :prompt nil)))))) + (setf (changedp query) t)))) + @@ -454,48 +498,23 @@ (declare (ignore stream)) (let ((estream (editing-stream record)) (ptype (ptype query)) - (view (view query)) - (accept-args (accept-arguments query))) + (view (view query))) (declare (ignore ptype view)) ;for now - (let* ((*activation-gestures* (apply #'make-activation-gestures - :existing-activation-gestures - (activation-gestures query) - accept-args)) - - (*delimiter-gestures* (apply #'make-delimiter-gestures - :existing-delimiter-args - (delimiter-gestures query) - accept-args))) - (with-accessors ((stream-activated stream-activated) - (stream-input-buffer stream-input-buffer)) + (with-accessors ((stream-input-buffer stream-input-buffer)) estream - ;; "deactivate" editing stream if user has previously activated it. - (when stream-activated - (setf stream-activated nil) - (when (activation-gesture-p (aref stream-input-buffer - (1- (fill-pointer - stream-input-buffer)))) - (replace-input estream "" - :buffer-start (1- (fill-pointer - stream-input-buffer)) - :rescan t))) - (setf (cursor-visibility estream) t) - (setf (snapshot record) (copy-seq stream-input-buffer)) - (block accept-condition-handler - (handler-bind ((condition #'(lambda (c) - (format *trace-output* - "accepting-values accept condition: ~A~%" - c) - (setf (accept-condition query) c) - (return-from accept-condition-handler - c)))) - (av-do-accept query record))))))) - + (setf (cursor-visibility estream) t) + (setf (snapshot record) (copy-seq stream-input-buffer)) + (av-do-accept query record t)))) +;;; If the query has not been changed (i.e., ACCEPT didn't return) and there is +;;; no error, act as if the user activated the query. (defmethod deselect-query (stream query (record av-text-record)) (let ((estream (editing-stream record))) - (setf (cursor-visibility estream) nil))) + (setf (cursor-visibility estream) nil) + (when (not (or (changedp query) (accept-condition query))) + (finalize-query-record query record)))) + (defgeneric finalize-query-record (query record) (:documentation "Do any cleanup on a query before the accepting-values body @@ -513,8 +532,7 @@ (defmethod finalize-query-record (query (record av-text-record)) (let ((estream (editing-stream record))) - (when (and (not (stream-activated estream)) - (snapshot record) + (when (and (snapshot record) (not (equal (snapshot record) (stream-input-buffer estream)))) (let* ((activation-gestures (apply #'make-activation-gestures @@ -524,13 +542,9 @@ (gesture (car activation-gestures))) (when gesture (let ((c (character-gesture-name gesture))) - (replace-input estream (string c) - :buffer-start (fill-pointer (stream-input-buffer - estream)) - :rescan nil) - (setf (stream-activated estream) t) + (activate-stream estream c) (reset-scan-pointer estream) - (av-do-accept query record))))))) + (av-do-accept query record nil))))))) (defun finalize-query-records (av-stream) (loop for query in (queries av-stream) Index: mcclim/incremental-redisplay.lisp diff -u mcclim/incremental-redisplay.lisp:1.44 mcclim/incremental-redisplay.lisp:1.45 --- mcclim/incremental-redisplay.lisp:1.44 Fri Feb 11 13:55:49 2005 +++ mcclim/incremental-redisplay.lisp Tue Feb 22 15:00:10 2005 @@ -728,6 +728,33 @@ ;;; work in progress (defvar *existing-output-records* nil) +;;; Helper functions for managing a hash table of records + +(defun get-record-hash (record hash) + (let ((bucket (gethash (slot-value record 'coordinates) hash))) + (if (null bucket) + (values nil nil) + (let ((rec (find record bucket :test #'output-record-equal))) + (if rec + (values rec t) + (values nil nil)))))) + +(defun add-record-hash (record hash) + (push record (gethash (slot-value record 'coordinates) hash nil))) + +(defun delete-record-hash (record hash) + (let ((bucket (gethash (slot-value record 'coordinates) hash))) + (if bucket + (multiple-value-bind (new-bucket deleted) + (delete-1 record bucket :test #'output-record-equal) + (if deleted + (progn + (setf (gethash (slot-value record 'coordinates) hash) + new-bucket) + t) + nil)) + nil))) + (defmethod compute-difference-set ((record standard-updating-output-record) &optional (check-overlapping t) offset-x offset-y @@ -735,8 +762,7 @@ (declare (ignore offset-x offset-y old-offset-x old-offset-y)) (when (eq (output-record-dirty record) :clean) (return-from compute-difference-set (values nil nil nil nil nil))) - (let* ((existing-output-records nil) - (draws nil) + (let* ((draws nil) (moves (explicit-moves record)) (erases nil) (erase-overlapping nil) @@ -751,33 +777,34 @@ (and old-children (region-intersects-region-p visible-region old-children))) (return-from compute-difference-set (values nil nil nil nil nil))) - ;; I don't feel like adding another let and indenting this huge function - ;; some more.... - (setq existing-output-records (make-hash-table :test #'eq)) ;; XXX This means that compute-difference-set can't be called repeatedly on ;; the same tree; ugh. On the other hand, if we don't clear explicit-moves, ;; they can hang around in the tree for later passes and cause trouble. (setf (explicit-moves record) nil) - ;; Find output records in the new tree that match a record in the old tree - ;; i.e., already have a valid display on the screen. - (map-over-child-display - (if old-children + (let ((existing-output-records (make-hash-table :test 'equalp))) + ;; Find output records in the new tree that match a record in the old + ;; tree i.e., already have a valid display on the screen. + (map-over-child-display + (if old-children + #'(lambda (r) + (add-record-hash r existing-output-records)) + #'(lambda (r) (push (list r r) draws))) + (sub-record record) + visible-region) + (when old-children + (map-over-child-display #'(lambda (r) - (let ((old (find-existing-record r old-children visible-region))) - (if old - (setf (gethash old existing-output-records) r) - (push (list r r) draws)))) - #'(lambda (r) (push (list r r) draws))) - (sub-record record) - visible-region) - ;; Find old records that should be erased - (when old-children - (map-over-child-display #'(lambda (r) - (unless (gethash r existing-output-records) - (push (list r (copy-bounding-rectange r)) - erases))) - old-children - visible-region)) + (unless (delete-record-hash r existing-output-records) + (push (list r (copy-bounding-rectange r)) erases))) + old-children + visible-region) + ;; Any records left in the hash table do not have a counterpart + ;; visible on the screen and need to be drawn. + (loop + for bucket being the hash-values of existing-output-records + do (loop + for r in bucket + do (push (list r r) draws))))) (when check-overlapping (setf erase-overlapping (nconc erases draws)) (setf move-overlapping moves) Index: mcclim/input-editing.lisp diff -u mcclim/input-editing.lisp:1.43 mcclim/input-editing.lisp:1.44 --- mcclim/input-editing.lisp:1.43 Sat Feb 5 00:23:49 2005 +++ mcclim/input-editing.lisp Tue Feb 22 15:00:11 2005 @@ -45,7 +45,7 @@ (scan-pointer :accessor stream-scan-pointer :initform 0) (rescan-queued :accessor rescan-queued :initform nil) (rescanning-p :reader stream-rescanning-p :initform nil) - (activated :accessor stream-activated :initform nil))) + (activation-gesture :accessor activation-gesture :initform nil))) ;;; Markers for noise strings in the input buffer. @@ -72,6 +72,7 @@ ;;; read in while it is not an activation gesture, unread, and then read again ;;; as an activation gesture. This kind of game seems to be needed for reading ;;; forms properly. -- moore +#-(and) (defmethod stream-read-gesture ((stream standard-input-editing-stream) &rest rest-args &key peek-p &allow-other-keys) @@ -84,7 +85,9 @@ (let ((gesture (aref buffer scan-pointer))) (cond ((typep gesture 'noise-string-property) (incf scan-pointer)) - ; XXX What about if peek-p is true? + ;; XXX What about if peek-p is true? + ;; I'm thinking that accept should look for accept + ;; results explicitly. -- moore ((and (not peek-p) (typep gesture 'goatee::accept-result-extent)) (incf scan-pointer) @@ -95,7 +98,9 @@ (setf (stream-activated stream) t)) (incf scan-pointer)) (return-from stream-read-gesture gesture))))) - ;; If activated, insertion pointer is at fill pointer + ;; If activated, insertion pointer is at fill pointer XXX get rid + ;; of this + #+(or) ((stream-activated stream) (return-from stream-read-gesture (values nil :eof))) (t (when (eql scan-pointer (fill-pointer buffer)) @@ -113,7 +118,64 @@ type)) until result))))))) +(defmethod stream-read-gesture ((stream standard-input-editing-stream) + &rest rest-args &key peek-p + &allow-other-keys) + (with-keywords-removed (rest-args (:peek-p)) + (rescan-if-necessary stream) + (with-slots (buffer insertion-pointer scan-pointer activation-gesture) + stream + (loop + (loop + while (< scan-pointer insertion-pointer) + do (let ((gesture (aref buffer scan-pointer))) + ;; Skip noise strings. + ;; XXX We should skip accept results too; I think that they + ;; should be consumed by ACCEPT-1. That's not happening yet. + (cond ((characterp gesture) + (unless peek-p + (incf scan-pointer)) + (return-from stream-read-gesture gesture)) + ((and (not peek-p) + (typep gesture 'goatee::accept-result-extent)) + (incf scan-pointer) + (throw-object-ptype (goatee::object gesture) + (goatee::result-type gesture))) + (t (incf scan-pointer))) + (if (characterp gesture) + (progn + (unless peek-p + (incf scan-pointer)) + (return-from stream-read-gesture gesture)) + (incf scan-pointer)))) + ;; The scan pointer should not be greater than the insertion pointer + ;; because the code that set the insertion pointer should have queued + ;; a rescan. + (when (> scan-pointer insertion-pointer) + (warn "scan-pointer ~S > insertion-pointer ~S; shouldn't happen" + scan-pointer insertion-pointer) + (immediate-rescan stream)) + (when activation-gesture + (return-from stream-read-gesture + (prog1 + activation-gesture + (unless peek-p + (setf activation-gesture nil))))) + (setf (slot-value stream 'rescanning-p) nil) + ;; In McCLIM stream-process-gesture is responsible for inserting + ;; characters into the buffer, changing the insertion pointer and + ;; possibly setting up the activation-gesture slot. + (loop + with gesture and type + do (setf (values gesture type) + (apply #'stream-read-gesture + (encapsulating-stream-stream stream) rest-args)) + when (null gesture) + do (return-from stream-read-gesture (values gesture type)) + when (stream-process-gesture stream gesture type) + do (loop-finish)))))) +#-(and) (defmethod stream-unread-gesture ((stream standard-input-editing-stream) gesture) (declare (ignore gesture)) @@ -121,7 +183,33 @@ (setf (stream-activated stream) nil) (decf (stream-scan-pointer stream)))) -(defgeneric stream-process-gesture (stream gesture type)) +(defmethod stream-unread-gesture ((stream standard-input-editing-stream) + gesture) + (with-slots (buffer scan-pointer activation-gesture) + stream + (when (> scan-pointer 0) + (if (and (eql scan-pointer (fill-pointer buffer)) + (activation-gesture-p gesture)) + (setf activation-gesture gesture) + (decf scan-pointer))))) + +(defgeneric activate-stream (stream gesture) + (:documentation "Cause the input editing stream STREAM to be activated with + GESTURE")) + +(defmethod activate-stream ((stream standard-input-editing-stream) gesture) + (setf (activation-gesture stream) gesture) + (setf (stream-insertion-pointer stream) + (fill-pointer (stream-input-buffer stream))) + (goatee::set-editing-stream-insertion-pointer + stream + (stream-insertion-pointer stream))) + +(defgeneric stream-process-gesture (stream gesture type) + (:documentation "McCLIM relys on a text editor class (by default + GOATEE-INPUT-EDITING-MIXIN) to perform the user interaction and display for + input editing. Also, that class must update the stream buffer and the + insertion pointer, cause rescans to happen, and handle activation gestures.")) ;;; The editing functions of stream-process-gesture are performed by the ;;; primary method on goatee-input-editing-mixin @@ -768,7 +856,11 @@ "Invoke the continuation of the empty `accept' before the first non-empty accept `gesture' must be a member of that `accept''s activation or continuation gestures." - (let ((scan-pointer (1- (stream-scan-pointer stream)))) + (let* ((activationp (activation-gesture-p gesture)) + (scan-pointer (if activationp ;activation gestures don't appear in + ;the bufffer + (stream-scan-pointer stream) + (1- (stream-scan-pointer stream))))) (loop with active-continuation-function = nil for continuation in *empty-input-continuations* @@ -776,7 +868,8 @@ = continuation while (and (eq stream cont-stream) (eql scan-pointer cont-scan-pointer)) - when (or (gesture-match gesture activations) + when (if activationp + (gesture-match gesture activations) (gesture-match gesture delimeters)) do (setq active-continuation-function func) end Index: mcclim/presentation-defs.lisp diff -u mcclim/presentation-defs.lisp:1.41 mcclim/presentation-defs.lisp:1.42 --- mcclim/presentation-defs.lisp:1.41 Sat Jan 22 23:31:08 2005 +++ mcclim/presentation-defs.lisp Tue Feb 22 15:00:11 2005 @@ -981,18 +981,27 @@ (defun highlight-presentation-1 (presentation stream state) (with-output-recording-options (stream :record nil) - (if (or (eq (presentation-single-box presentation) t) - (eq (presentation-single-box presentation) :highlighting)) - (highlight-output-record-rectangle presentation stream state) - (funcall-presentation-generic-function highlight-presentation - (presentation-type presentation) - presentation - stream - state)))) + (funcall-presentation-generic-function highlight-presentation + (presentation-type presentation) + presentation + stream + state))) (define-default-presentation-method highlight-presentation (type record stream state) - (highlight-output-record record stream state)) + (declare (ignore type)) + (if (or (eq (presentation-single-box record) t) + (eq (presentation-single-box record) :highlighting)) + (highlight-output-record-rectangle record stream state) + (labels ((highlighter (record) + (typecase record + (displayed-output-record + (highlight-output-record record stream state)) + (compound-output-record + (map-over-output-records #'highlighter record)) + (t nil)))) + (highlighter record)))) + (define-default-presentation-method present (object type stream (view textual-view) &key acceptably for-context-type) Index: mcclim/stream-input.lisp diff -u mcclim/stream-input.lisp:1.41 mcclim/stream-input.lisp:1.42 --- mcclim/stream-input.lisp:1.41 Tue Jan 11 16:33:32 2005 +++ mcclim/stream-input.lisp Tue Feb 22 15:00:11 2005 @@ -330,33 +330,30 @@ ;;; Standard stream methods on standard-extended-input-stream. Ignore any ;;; pointer gestures in the input buffer. - - -(defun read-gesture-or-reason (stream &rest args) - (multiple-value-bind (result reason) - (apply #'stream-read-gesture stream args) - (or result reason))) - -(defun read-result-p (gesture) - (or (characterp gesture) - (member gesture '(:eof :timeout) :test #'eq))) +;;; +;;; Is stream-read-gesture allowed to return :eof? (defmethod stream-read-char ((stream standard-extended-input-stream)) (with-encapsulating-stream (estream stream) - (loop for char = (read-gesture-or-reason estream) - until (read-result-p char) - finally (return (char-for-read char))))) + (loop + with char and reason + do (setf (values char reason) (stream-read-gesture estream)) + until (or (characterp char) (eq reason :eof)) + finally (return (if (eq reason :eof) + reason + (char-for-read char)))))) (defmethod stream-read-char-no-hang ((stream standard-extended-input-stream)) (with-encapsulating-stream (estream stream) - (loop for char = (read-gesture-or-reason estream :timeout 0) - do (when (read-result-p char) - (loop-finish)) - finally (return (cond ((eq char :eof) - :eof) - ((eq char :timeout) - nil) - (t (char-for-read char))))))) + (loop + with char and reason + do (setf (values char reason) (stream-read-gesture estream :timeout 0)) + until (or (characterp char) (eq reason :timeout) (eq reason :eof) ) + finally (return (cond ((eq reason :timeout) + nil) + ((eq reason :eof) + :eof) + (t (char-for-read char))))))) (defmethod stream-unread-char ((stream standard-extended-input-stream) char) @@ -365,20 +362,25 @@ (defmethod stream-peek-char ((stream standard-extended-input-stream)) (with-encapsulating-stream (estream stream) - (loop for char = (read-gesture-or-reason estream :peek-p t) - do (if (read-result-p char) - (loop-finish) - (stream-read-gesture estream)) ; consume pointer gesture - finally (return (char-for-read char))))) + (loop + with char and reason + do (setf (values char reason) (stream-read-gesture estream :peek-p t)) + until (or (characterp char) (eq reason :eof)) + do (stream-read-gesture estream) ; consume pointer gesture + finally (return (if (eq reason :eof) + reason + (char-for-read char)))))) (defmethod stream-listen ((stream standard-extended-input-stream)) (with-encapsulating-stream (estream stream) - (loop for char = (read-gesture-or-reason estream :timeout 0 :peek-p t) - do (if (read-result-p char) - (loop-finish) - (stream-read-gesture estream)) ; consume pointer gesture - finally (return (characterp char))))) - + (loop + with char and reason + do (setf (values char reason) (stream-read-gesture estream + :timeout 0 + :peek-p t)) + until (or (characterp char) (eq reason :eof) (eq reason :timeout)) + do (stream-read-gesture estream) ; consume pointer gesture + finally (return (characterp char))))) ;;; stream-read-line returns a second value of t if terminated by eof. (defmethod stream-read-line ((stream standard-extended-input-stream))