[climacs-cvs] CVS esa
crhodes
crhodes at common-lisp.net
Wed May 10 09:41:42 UTC 2006
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 ()
+ , at 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)
More information about the Climacs-cvs
mailing list