Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv29508

Modified Files: esa.lisp Log Message: write a primary STREAM-ACCEPT method for the minibuffer. This basically does the same as the usual STREAM-ACCEPT, except that it turns input sensitizing off (which works around the problem with Goatee with nested accepts on the same extended stream). Some other bits are slightly less hairy, too.

--- /project/climacs/cvsroot/esa/esa.lisp 2006/05/10 08:41:49 1.13 +++ /project/climacs/cvsroot/esa/esa.lisp 2006/05/10 09:41:42 1.14 @@ -70,6 +70,160 @@ (parse-error () nil))))

+(defmethod stream-accept ((pane minibuffer-pane) type &rest args + &key (view (stream-default-view pane)) + &allow-other-keys) + ;; default CLIM prompting is OK for now... + (apply #'prompt-for-accept pane type view args) + ;; but we need to turn some of ACCEPT-1 off. + (apply #'accept-1-for-minibuffer pane type args)) + +;;; simpler version of McCLIM's internal operators of the same names: +;;; HANDLE-EMPTY-INPUT to make default processing work, EMPTY-INPUT-P +;;; and INVOKE-HANDLE-EMPTY-INPUT to support it. We don't support +;;; recursive bouncing to see who most wants to handle the empty +;;; input, but that's OK, because we are always conceptually one-level +;;; deep in accept (even if sometimes we call ACCEPT recursively for +;;; e.g. command-names and arguments). +(defmacro handle-empty-input ((stream) input-form &body handler-forms) + "see climi::handle-empty-input" + (let ((input-cont (gensym "INPUT-CONT")) + (handler-cont (gensym "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)))) + +;;; 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 activation-gestures delimiter-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) + (flet ((gesture-matches-p (g) + (if (characterp g) + (char= gesture g) + ;; FIXME: not quite portable -- + ;; apparently + ;; EVENT-MATCHES-GESTURE-NAME-P need + ;; not work on raw characters + (event-matches-gesture-name-p gesture g)))) + (or (some #'gesture-matches-p activation-gestures) + (some #'gesture-matches-p delimiter-gestures)))))) + (t 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)) + (activation-gestures *activation-gestures*) + (delimiter-gestures *delimiter-gestures*)) + (block empty-input + (handler-bind + ((parse-error + #'(lambda (c) + (when (empty-input-p stream begin-scan-pointer + activation-gestures delimiter-gestures) + (return-from empty-input nil))))) + (return-from invoke-handle-empty-input (funcall input-continuation)))) + (funcall handler-continuation))) + +(defun accept-1-for-minibuffer + (stream type &key + (view (stream-default-view stream)) + (default nil defaultp) (default-type nil default-type-p) + provide-default insert-default (replace-input t) + history active-p prompt prompt-mode display-default + query-identifier (activation-gestures nil activationsp) + (additional-activation-gestures nil additional-activations-p) + (delimiter-gestures nil delimitersp) + (additional-delimiter-gestures nil additional-delimiters-p)) + (declare (ignore provide-default history active-p + prompt prompt-mode + display-default query-identifier)) + (when (and defaultp (not default-type-p)) + (error ":default specified without :default-type")) + (when (and activationsp additional-activations-p) + (error "only one of :activation-gestures or ~ + :additional-activation-gestures may be passed to accept.")) + (unless (or activationsp additional-activations-p *activation-gestures*) + (setq activation-gestures *standard-activation-gestures*)) + (with-input-editing + ;; this is the main change from CLIM:ACCEPT-1 -- no sensitizer. + (stream :input-sensitizer nil) + ;; KLUDGE: no call to CLIMI::WITH-INPUT-POSITION here, but that's + ;; OK because we are always going to create a new editing stream + ;; for each call to accept/accept-1-for-minibuffer, so the default + ;; default for the BUFFER-START argument to REPLACE-INPUT is + ;; right. + (when insert-default + ;; Insert the default value to the input stream. It should + ;; become fully keyboard-editable. + (presentation-replace-input + stream default default-type view)) + (with-input-context (type) + (object object-type event options) + (with-activation-gestures ((if additional-activations-p + additional-activation-gestures + activation-gestures) + :override activationsp) + (with-delimiter-gestures ((if additional-delimiters-p + additional-delimiter-gestures + delimiter-gestures) + :override delimitersp) + (let ((accept-results nil)) + (climi::handle-empty-input (stream) + (setq accept-results + (multiple-value-list + (if defaultp + (funcall-presentation-generic-function + accept type stream view + :default default :default-type default-type) + (funcall-presentation-generic-function + accept type stream view)))) + ;; User entered activation or delimiter gesture + ;; without any input. + (if defaultp + (presentation-replace-input + stream default default-type view :rescan nil) + (simple-parse-error + "Empty input for type ~S with no supplied default" + type)) + (setq accept-results (list default default-type))) + ;; Eat trailing activation gesture + ;; XXX what about pointer gestures? + ;; XXX and delimiter gestures? + ;; + ;; deleted check for *RECURSIVE-ACCEPT-P* + (let ((ag (read-char-no-hang stream nil stream t))) + (unless (or (null ag) (eq ag stream)) + (unless (activation-gesture-p ag) + (unread-char ag stream)))) + (values (car accept-results) + (if (cdr accept-results) (cadr accept-results) type))))) + ;; A presentation was clicked on, or something. + (t + (when (and replace-input + (getf options :echo t) + (not (stream-rescanning-p stream))) + (presentation-replace-input + stream object object-type view :rescan nil)) + (values object object-type))))) + (defun display-minibuffer (frame pane) (declare (ignore frame)) (when (message pane)