[mcclim-cvs] CVS update: mcclim/dialog.lisp mcclim/input-editing.lisp mcclim/presentation-defs.lisp
Timothy Moore
tmoore at common-lisp.net
Fri Feb 25 14:15:19 UTC 2005
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)))
- , at handler-forms)))
+ (with-gensyms (input-cont handler-cont)
+ `(flet ((,input-cont ()
+ ,input-form)
+ (,handler-cont ()
+ , at 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 ()
More information about the Mcclim-cvs
mailing list