Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv31004
Modified Files: dialog.lisp input-editing.lisp presentation-defs.lisp Log Message:
Changed the handling of "empty input" for the purposes of returning a default value from ACCEPT. I eliminated the around method on STREAM-READ-CHAR that looked for activation/delimiter gestures and replaced it with an error handler on SIMPLE-PARSE-ERROR. The major effect of this is that (accept 'string) now return the empty string if the call to ACCEPT is not passed a default; other accept methods can return something useful for empty input too. This fixes some problems in the address book demo and with dialogs in general.
Date: Fri Feb 25 15:15:17 2005 Author: tmoore
Index: mcclim/dialog.lisp diff -u mcclim/dialog.lisp:1.18 mcclim/dialog.lisp:1.19 --- mcclim/dialog.lisp:1.18 Tue Feb 22 15:00:10 2005 +++ mcclim/dialog.lisp Fri Feb 25 15:15:17 2005 @@ -256,6 +256,13 @@ :key #'query-identifier :test #'equal)) (align (align-prompts stream))) (unless query + ;; If there's no default but empty input could return a sensible value, + ;; use that as a default. + (unless default-supplied-p + (setq default + (ignore-errors (accept-from-string type + "" + :view +textual-view+ )))) (setq query (make-instance 'query :query-identifier query-identifier :ptype type
Index: mcclim/input-editing.lisp diff -u mcclim/input-editing.lisp:1.44 mcclim/input-editing.lisp:1.45 --- mcclim/input-editing.lisp:1.44 Tue Feb 22 15:00:11 2005 +++ mcclim/input-editing.lisp Fri Feb 25 15:15:17 2005 @@ -848,76 +848,76 @@ ;;; Infrasructure for detecting empty input, thus allowing accept-1 ;;; to supply a default.
-;;; continuation = (stream scan-pointer <function of one arg (gesture)> -;;; activation-gestures delimiter gestures) -(defvar *empty-input-continuations* nil) - -(defun invoke-empty-input (stream gesture) - "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* ((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* - for (cont-stream cont-scan-pointer func activations delimeters) - = continuation - while (and (eq stream cont-stream) - (eql scan-pointer cont-scan-pointer)) - when (if activationp - (gesture-match gesture activations) - (gesture-match gesture delimeters)) - do (setq active-continuation-function func) - end - finally (when active-continuation-function - (unread-char gesture stream) - (funcall active-continuation-function))) - t)) - -(defmethod stream-read-gesture :around ((stream empty-input-mixin) - &key timeout peek-p - input-wait-test - input-wait-handler - pointer-button-press-handler) - (declare (ignore timeout input-wait-test input-wait-handler - pointer-button-press-handler)) - (if peek-p - (call-next-method) - (multiple-value-bind (gesture reason) - (call-next-method) - (when (and gesture - (or (activation-gesture-p gesture) - (delimiter-gesture-p gesture))) - (invoke-empty-input stream gesture)) - ;; invoke-empty-input won't return if it can invoke a continuation - (values gesture reason)))) - (defmacro handle-empty-input ((stream) input-form &body handler-forms) "Establishes a context on `stream' (a `standard-input-editing-stream') in - which empty input entered in `input-form' i.e., an activation gesture or - delimiter gesture typed with no other characters, may transfer control to - `handler-forms'. The gesture that caused the transfer remains to be read in - `stream'. Control is transferred to the outermost `handle-empty-input' form - that is empty. + which empty input entered in `input-form' may transfer control to + `handler-forms'. Empty input is assumed when a simple-parse-error is + signalled and there is a delimeter gesture or activation gesture in the + stream at the position where `input-form' began its input. The gesture that + caused the transfer remains to be read in `stream'. Control is transferred to + the outermost `handle-empty-input' form that is empty.
Note: noise strings in the buffer, such as the prompts of recursive calls to `accept', cause input to not be empty. However, the prompt generated by `accept' is generally not part of its own empty input context." - (with-gensyms (return-block context-block) - `(block ,return-block - (block ,context-block - (let ((*empty-input-continuations* - (cons (list ,stream - (stream-scan-pointer ,stream) - #'(lambda () - (return-from ,context-block)) - *activation-gestures* - *delimiter-gestures*) - *empty-input-continuations*))) - (return-from ,return-block ,input-form))) - ,@handler-forms))) + (with-gensyms (input-cont handler-cont) + `(flet ((,input-cont () + ,input-form) + (,handler-cont () + ,@handler-forms)) + (declare (dynamic-extent #',input-cont #',handler-cont)) + (invoke-handle-empty-input ,stream #',input-cont #',handler-cont)))) + +(define-condition empty-input-condition (simple-condition) + ((stream :reader empty-input-condition-stream :initarg :stream))) + +;;; The code that signalled the error might have consumed the gesture, or +;;; not. +;;; XXX Actually, it would be a violation of the `accept' protocol to consume +;;; the gesture, but who knows what random accept methods are doing. +(defun empty-input-p (stream begin-scan-pointer completion-gestures) + (let ((scan-pointer (stream-scan-pointer stream)) + (fill-pointer (fill-pointer (stream-input-buffer stream)))) + ;; activated? + (cond ((and (eql begin-scan-pointer scan-pointer) + (eql scan-pointer fill-pointer)) + t) + ((or (eql begin-scan-pointer scan-pointer) + (eql begin-scan-pointer (1- scan-pointer))) + (let ((gesture (aref (stream-input-buffer stream) + begin-scan-pointer))) + (and (characterp gesture) + (gesture-match gesture completion-gestures)))) + (t nil)))) + +;;; The control flow in here might be a bit confusing. The handler catches +;;; parse errors from accept forms and checks if the input stream is empty. If +;;; so, it resignals an empty-input-condition to see if an outer call to +;;; accept is empty and wishes to handle this situation. We don't resignal the +;;; parse error itself because it might get handled by a handler on ERROR in an +;;; accept method or in user code, which would screw up the default mechanism. +;;; +;;; If the situation is not handled in the innermost empty input handler, +;;; either directly or as a result of resignalling, then it won't be handled +;;; by any of the outer handlers as the stack unwinds, because EMPTY-INPUT-P +;;; will return nil. +(defun invoke-handle-empty-input + (stream input-continuation handler-continuation) + (unless (input-editing-stream-p stream) + (return-from invoke-handle-empty-input (funcall input-continuation))) + (let ((begin-scan-pointer (stream-scan-pointer stream)) + (completion-gestures *completion-gestures*)) + (block empty-input + (handler-bind (((or simple-parse-error empty-input-condition) + #'(lambda (c) + (when (empty-input-p stream + begin-scan-pointer + completion-gestures) + (if (typep c 'empty-input-condition) + (signal c) + (signal 'empty-input-condition :stream stream)) + ;; No one else wants to handle it, so we will + (return-from empty-input nil))))) + (return-from invoke-handle-empty-input (funcall input-continuation)))) + (funcall handler-continuation)))
Index: mcclim/presentation-defs.lisp diff -u mcclim/presentation-defs.lisp:1.42 mcclim/presentation-defs.lisp:1.43 --- mcclim/presentation-defs.lisp:1.42 Tue Feb 22 15:00:11 2005 +++ mcclim/presentation-defs.lisp Fri Feb 25 15:15:17 2005 @@ -1082,6 +1082,12 @@ (declare (ignore object acceptably for-context-type)) (write-string "None" stream))
+(define-presentation-method accept ((type null) stream (view textual-view) + &key) + (values (completing-from-suggestions (stream) + (suggest "None" nil) + (suggest "" nil)))) + (define-presentation-type boolean () :inherit-from t)
@@ -1388,12 +1394,15 @@ (princ object stream))
(define-presentation-method accept ((type string) stream (view textual-view) - &key) + &key (default nil defaultp) + (default-type type)) (let ((result (read-token stream))) (cond ((numberp length) (if (eql length (length result)) (values result type) (input-not-of-required-type result type))) + ((and (zerop (length result)) defaultp) + (values default default-type)) (t (values result type)))))
(define-presentation-type pathname ()