CLIM mail archive
[Prev][Next][Index][Thread]
Re: Accept's input buffer editting manipulation
Date: Mon, 6 Jul 1992 13:08-0400
From: Scott McKay <SWM@stony-brook.scrc.symbolics.com>
Subject: Accept's input buffer editting manipulation
To: curt@eraserhead.jpl.nasa.gov, clim@BBN.COM
Date: Mon, 6 Jul 1992 11:34 EDT
From: Curt Eggemeyer <curt@eraserhead.jpl.nasa.gov>
I wish to have my own accept method complete the users input when he hits a
return while in the middle of performing an inline edit on his input.
Presently, if you do an (accept 'number)
And the user enters -> 2034.45
But then does a meta-b and 3 control-b then a meta-d and enters 43 the
input looks like -> 2043.45 with the text cursor at the decimal point.
If the user hits a carriage return you only get 2043 from the accept.
How can I get my accept method when it sees the carriage return to
complete the input first so it would return 2043.45? Is there an easy way
to do this?
I fixed this bug a while back, but don't presently have access to the
patch file. Perhaps Jeff Morrill will forward the patch to you.
I'll forward it to everybody. This is a set of patches to the input editor
of CLIM 1.1. It's good stuff.
--------
;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: CLIM; Base: 10; Patch-File: T -*-
;;; Patch file for Private version 0.0
;;; Reason: Function (CLOS:METHOD CLIM::RESCAN-IF-NECESSARY (CLIM::INTERACTIVE-STREAM-MIXIN)): Merge
;;; this with RESCAN-FOR-ACTIVATION, and flush the latter.
;;; Function (METHOD STREAM-READ-GESTURE (INTERACTIVE-STREAM-MIXIN)): Inhibit activation rescans,
;;; reverse two clauses that could only ever have been buggy.
;;; Function CLIM:READ-TOKEN: Use RESCAN-IF-NECESSARY.
;;; Function CLIM:COMPLETE-INPUT: ..
;;; Function CLIM::SIMPLE-LISP-OBJECT-PARSER: ..
;;; Function (CLOS:METHOD CLIM::ACCEPT-METHOD (#<CLIM::PRESENTATION-TYPE-CLASS CLIM:EXPRESSION 11750527> T T T T CLIM:TEXTUAL-VIEW)): ..
;;; Macro DEFINE-INPUT-EDITOR-COMMAND: Make the default behavior be to queue a rescan, not do an
;;; immediate rescan.
;;; Recompile all the affected IE commands.
;;; Written by SWM, 4/23/92 11:26:44
;;; while running on Zion from FEP0:>see-clim-8-1-1.load.1
;;; with Genera 8.1.1, Logical Pathnames Translation Files NEWEST, CLIM 28.5,
;;; CLIM Demo 28.2, CLX 431.0, microcode 3640-FPA-MIC 430, FEP 127,
;;; FEP0:>v127-lisp.flod(64), FEP0:>v127-loaders.flod(64), FEP0:>v127-info.flod(64),
;;; FEP0:>v127-debug.flod(38), 1067x748 B&W Screen, Machine serial number 4001.
(in-package :clim)
(eval-when (compile load eval)
(fmakunbound 'clim::rescan-if-necessary))
;; Do a rescan if one is pending.
;; If it's an "activation" rescan, that means that the user typed an activation
;; character at some point, so this rescan should terminate all input. That's
;; why we set the insertion pointer to the end of the buffer...
;; In the cases where the program is maintaining another input buffer besides
;; the input editor's buffer, that buffer can get out of synch (for instance,
;; it could appear to be empty) because the user yanked something in and then
;; immediately hit <End>. In that case, the yank commands have left a rescan
;; pending which we can take care of now. In general, any piece of code that
;; is maintaining an input buffer separate from the input editor's buffer should
;; call RESCAN-IF-NECESSARY before parsing any input.
(defmethod rescan-if-necessary ((istream interactive-stream-mixin)
&optional inhibit-activation)
(with-slots (rescan-queued input-buffer insertion-pointer) istream
(when rescan-queued
(when (and (eql rescan-queued ':activation)
(not inhibit-activation))
(setq insertion-pointer (fill-pointer input-buffer)))
(setf rescan-queued nil)
(throw 'rescan (values)))))
#+genera
(scl:fundefine '(method stream-read-gesture (interactive-stream-mixin)))
(defmethod stream-read-gesture
((istream interactive-stream-mixin)
&key timeout peek-p
(input-wait-test *input-wait-test*)
(input-wait-handler *input-wait-handler*)
(pointer-button-press-handler *pointer-button-press-handler*))
(rescan-if-necessary istream t)
(with-slots (stream input-buffer scan-pointer insertion-pointer
activation-character rescanning-p
numeric-argument previous-history) istream
(declare (fixnum scan-pointer insertion-pointer))
(loop ;until a real gesture is read or we throw out
;; First look in the input-buffer of the input-editor and see
;; if there's something there.
(loop
(cond ((= scan-pointer insertion-pointer)
(return))
((< scan-pointer insertion-pointer)
(let ((gesture (aref input-buffer scan-pointer)))
(cond ((characterp gesture)
(unless peek-p (incf scan-pointer))
(return-from stream-read-gesture (values gesture)))
(t (incf scan-pointer)))))
(t (return)
;; If the scan pointer is greater than the insertion pointer
;; then we'll definitely have to rescan if a character is typed
;; at this point.
)))
;; If we're about to go to the stream but there's an activation
;; character buffered, return it instead.
(when activation-character
(return-from stream-read-gesture
(prog1 activation-character
(unless peek-p
(setf activation-character nil)))))
;;--- This is presumably much slower than necessary.
;;--- Perhaps there is a better way to keep track of where the cursor should be.
(multiple-value-bind (x-pos y-pos)
(input-buffer-input-position->cursor-position* istream insertion-pointer)
(declare (fixnum x-pos y-pos))
(multiple-value-bind (cx cy)
(stream-cursor-position* stream)
(declare (fixnum cx cy))
;; Don't set the cursor position if it's already right.
;; This prevents the input editor from scrolling the window after
;; the user has scrolled it back until the cursor position actually changes.
(unless (and (= cx x-pos) (= cy y-pos))
(stream-set-cursor-position* stream x-pos y-pos))))
(setf rescanning-p nil)
(multiple-value-bind (thing type)
(let ((*accelerator-numeric-argument*
(or numeric-argument 1))
(*accelerator-characters*
;; If there's anything in the input buffer, disallow accelerators
(and (zerop (fill-pointer input-buffer)) *accelerator-characters*)))
(stream-read-gesture stream
:timeout timeout :peek-p peek-p
:input-wait-test input-wait-test
:input-wait-handler input-wait-handler
:pointer-button-press-handler pointer-button-press-handler))
(cond ((eql type ':timeout)
(return-from stream-read-gesture
(values thing type)))
(peek-p
(return-from stream-read-gesture
(values thing type)))
(t
(multiple-value-bind (new-thing new-type)
;; This can throw out in order to do rescans.
;; NEW-THING is a character, a presentation "blip", or NIL
(interactive-stream-process-gesture istream thing type)
(when (and (characterp new-thing)
;; Don't put things in the buffer that we can't echo later
(ordinary-char-p new-thing)
(not (activation-character-p new-thing)))
(dotimes (i (or numeric-argument 1))
#-(or excl Minima) (declare (ignore i))
(cond ((< insertion-pointer (fill-pointer input-buffer))
(erase-input-buffer istream insertion-pointer)
(setq input-buffer (shift-buffer-portion
input-buffer
insertion-pointer (1+ insertion-pointer)))
(setf (aref input-buffer insertion-pointer) new-thing)
(redraw-input-buffer istream insertion-pointer)
(let ((rescan (> scan-pointer insertion-pointer)))
(incf insertion-pointer)
(if rescan
(immediate-rescan istream)
(setf scan-pointer insertion-pointer))))
(t (vector-push-extend new-thing input-buffer)
(incf scan-pointer)
(incf insertion-pointer)
(when (ordinary-char-p new-thing)
(write-char new-thing istream))))))
(when new-thing
(setq numeric-argument nil
previous-history nil)
(cond ((activation-character-p new-thing)
;; If we got an activation character, we must first finish
;; scanning the input line, moving the insertion-pointer
;; to the end and finishing rescanning. Only then can we
;; return the activation character.
(cond ((= insertion-pointer (fill-pointer input-buffer))
(return-from stream-read-gesture
(values new-thing new-type)))
(t (setf insertion-pointer (fill-pointer input-buffer))
(setf activation-character new-thing))))
((or (not (characterp new-thing))
(ordinary-char-p new-thing))
;; There might be some queued up rescans from destructive
;; input editing commands, so take care of them now
(rescan-if-necessary istream t)
(return-from stream-read-gesture
(values new-thing new-type)))
(t
;; Some input editing doesn't throw, and should not
;; cause us to return just yet, since IE commands don't
;; count as real gestures.
(beep istream)))))))))))
;; READ-TOKEN reads characters until it encounters an activation character,
;; a blip character, or something else (like a mouse click).
(defun read-token (stream &key input-wait-handler pointer-button-press-handler
click-only timeout)
(with-temporary-string (string :length 50 :adjustable t)
(let* ((gesture nil)
(gesture-type nil)
(quote-seen nil)
(old-blip-chars *blip-characters*)
(*blip-characters* *blip-characters*))
(flet ((return-token (&optional unread)
(when unread
(unread-gesture unread :stream stream))
(when (and (activation-character-p unread)
(interactive-stream-p stream))
(rescan-if-necessary stream))
(return-from read-token
(values (evacuate-temporary-string string)))))
(loop
(multiple-value-setq (gesture gesture-type)
(read-gesture :stream stream
:input-wait-handler
(or input-wait-handler
*input-wait-handler*)
:pointer-button-press-handler
(or pointer-button-press-handler
*pointer-button-press-handler*)
:timeout (and click-only timeout)))
(cond ((eql gesture-type :timeout)
(return-from read-token :timeout))
((and click-only
(not (typep gesture 'pointer-button-event)))
(beep stream))
((typep gesture 'pointer-button-event)
;; No need to do anything, since this should have been handled
;; in the presentation type system already
)
((characterp gesture)
(cond ((and (zerop (fill-pointer string))
(eql gesture *quotation-character*))
(setq quote-seen t)
(setq *blip-characters* nil))
((and quote-seen
(eql gesture *quotation-character*))
(setq quote-seen nil)
(setq *blip-characters* old-blip-chars))
((activation-character-p gesture)
(return-token gesture))
((blip-character-p gesture)
;; ditto?
(return-token gesture))
((ordinary-char-p gesture)
(vector-push-extend gesture string)
;;--- haven't updated WRITE-CHAR yet
#+ignore (write-char gesture stream))
(t (beep stream))))
(t (return-token gesture))))))))
(defun complete-input (stream function
&key partial-completers allow-any-input possibility-printer
(help-displays-possibilities t))
(declare (dynamic-extent function))
(declare (values answer-object success string))
(with-temporary-string (stuff-so-far :length 100 :adjustable t)
(with-blip-characters (partial-completers)
(with-activation-characters (*magic-completion-characters*)
(flet ((completion-help (stream action string-so-far)
(declare (ignore string-so-far))
(display-completion-possibilities
stream function stuff-so-far
:possibility-printer possibility-printer
:display-possibilities
(or (eql action :possibilities)
(and (eql action :help) help-displays-possibilities)))))
(declare (dynamic-extent #'completion-help))
(with-accept-help ((:subhelp #'completion-help))
;; Keep the input editor from handling help and possibilities characters.
;; They will get treated as activation characters, thus ensuring that
;; STUFF-SO-FAR will be accurate when we display the possibilities.
(let ((*ie-help-enabled* nil)
(location (input-position stream))
token ch
unread return extend
completion-mode completion-type
answer-object)
(flet ((ends-in-char-p (string char)
(let ((sl (length string)))
(and (plusp sl)
(char-equal (aref string (1- sl)) char)))))
(declare (dynamic-extent #'ends-in-char-p))
(loop
;; Maybe these, as well as TOKEN and CH should be LET inside the loop...
(setq unread nil return nil extend nil)
(setq token (read-token stream))
(setq ch (read-gesture :stream stream)) ;don't care about wait functions
(extend-vector stuff-so-far token)
(cond ((null ch)
(error "Null ch?"))
((characterp ch)
(cond ((member ch *help-characters*)
(setq completion-mode ':help))
((member ch *possibilities-characters*)
(setq completion-mode ':possibilities))
((member ch *complete-characters*)
(setq completion-mode ':complete-maximal))
((member ch partial-completers :test #'char-equal)
(setq completion-mode ':complete-limited
unread t extend t return 'if-completed))
;; What about "overloaded" partial completers??
((blip-character-p ch)
(setq completion-mode (if allow-any-input nil ':complete)
unread t extend t return t))
((activation-character-p ch)
(setq completion-mode (if allow-any-input nil ':complete)
unread t return t))))
((eq ch ':eof)
(setq completion-mode (if allow-any-input nil ':complete)
return t))
(t ;mouse click?
(beep stream)))
;; OK, this is a SPECIAL case. We check to see if the null string
;; was read, and if so, we signal a parse-error (because ACCEPT
;; handles this specially) so that the default value will be filled
;; in by ACCEPT.
;; There is a tension here between wanting to fill in the default and
;; use the maximal left substring when the user types #\End or a field
;; terminator that also does completion. Putting this check before the
;; completion code means that the default always wins.
(when (and return (zerop (fill-pointer stuff-so-far)))
(when unread
(unread-gesture ch :stream stream))
(when (interactive-stream-p stream)
(rescan-if-necessary stream))
(simple-parse-error "Attempting to complete the null string"))
(cond ((or (eql completion-mode ':help)
(eql completion-mode ':possibilities))
;; Since we've asked the input editor not to do this,
;; we must do it here ourselves
(display-accept-help stream completion-mode "")
(setq completion-type nil))
(completion-mode
(multiple-value-bind (string success object nmatches)
(funcall function stuff-so-far completion-mode)
(setq answer-object object)
(cond ((= nmatches 0)
;; no valid completion, so no replace input
(setq completion-type 'invalid)
(when extend
(vector-push-extend ch stuff-so-far)))
((= nmatches 1)
(setq completion-type (if success 'unique 'ambiguous))
;; replace contents of stuff-so-far with completion
(setf (fill-pointer stuff-so-far) 0)
(extend-vector stuff-so-far string)
)
((> nmatches 1)
(setq completion-type 'ambiguous)
;; replace contents of stuff-so-far with completion
(setf (fill-pointer stuff-so-far) 0)
(extend-vector stuff-so-far string)
;; need-to-add-delimiter test??
(when (and extend
(not (ends-in-char-p string ch)))
(vector-push-extend ch stuff-so-far)))))))
;; Check for errors unconditionally, remembering that we may not have
;; called the completer at all (completion-type = NIL)
(ecase completion-type
((nil unique left-substring)) ; no possible errors to report
(invalid
(unless allow-any-input
(when unread
(unread-gesture ch :stream stream))
(simple-parse-error "Invalid completion: ~A" stuff-so-far)))
(ambiguous
;; only beep on ambiguous full completions, in either ALLOW-ANY-INPUT mode
(when (eq completion-mode :complete)
(beep stream))))
(when (eq return 'if-completed)
(unless (eq completion-type 'unique)
(setq return nil)))
;; Decide whether or not to return, remembering that
;; we might have called the completer.
(when return
(when (or (member completion-type '(nil unique left-substring))
allow-any-input)
;; leave the last delimiter for our caller
(when unread
(unread-gesture ch :stream stream))
;; Must replace-input after unread-gesture so the delimiter is unread
;; into the input editor's buffer, not the underlying stream's buffer
(unless (rescanning-p stream)
(replace-input stream stuff-so-far :buffer-start location))
(return-from complete-input
(values answer-object t (evacuate-temporary-string stuff-so-far)))))
;; Not returning yet, but update the input editor's buffer anyway
(unless (rescanning-p stream)
(replace-input stream stuff-so-far :buffer-start location)))))))))))
(defun simple-lisp-object-parser (type stream &optional coerce-test coerce-function)
(loop
(let ((token (read-token stream)))
(when (interactive-stream-p stream)
(rescan-if-necessary stream))
(multiple-value-bind (object index)
(let ((*read-eval* nil)) ;disable "#."
(read-from-string token nil token))
(when (eq object token)
(simple-parse-error "Unexpected EOF"))
;; Too bad read-from-string doesn't take a :junk-allowed argument
;; Simulate what it would do
(unless (>= index (length token))
(when (find-if-not #'whitespace-character-p token :start index)
(simple-parse-error "Extra junk ~S found after the ~A."
(subseq token index)
(describe-presentation-type type nil nil))))
(when (presentation-typep object type)
(return-from simple-lisp-object-parser (values object type)))
(when coerce-function
(when (funcall coerce-test object)
(setq object (funcall coerce-function object))
(when (presentation-typep object type)
(return-from simple-lisp-object-parser (values object type)))))
(input-not-of-required-type token type)))))
(define-presentation-method accept ((type expression) stream (view textual-view) &key)
(let ((*read-recursive-objects* nil))
(with-temporary-string (string)
(read-recursive stream string nil)
(when (interactive-stream-p stream)
(rescan-if-necessary stream))
(multiple-value-bind (expression index)
(read-from-string string nil string)
(when (eq expression string)
(simple-parse-error "The input ~S is not a complete Lisp expression."
(evacuate-temporary-string string)))
;; Too bad READ-FROM-STRING doesn't take a :JUNK-ALLOWED argument.
;; Simulate what it would do
(unless (>= index (length string))
(when (find-if-not #'whitespace-character-p string :start index)
(simple-parse-error "Extra junk ~S found after the expression."
(subseq string index))))
expression))))
(defmacro define-input-editor-command ((name &key (rescan T) (type 'motion) history)
arglist &body body)
(multiple-value-bind (arglist ignores)
(canonicalize-and-match-lambda-lists *ie-command-arglist* arglist)
(let ((stream (first arglist)))
`(define-group ,name define-input-editor-command
(defun ,name ,arglist
,@(and ignores `((declare (ignore ,@ignores))))
,@body
(setf (slot-value ,stream 'last-command-type) ',type)
,@(unless history `((setf (slot-value ,stream 'previous-history) nil)))
,@(ecase rescan
((t) `((queue-rescan ,stream)))
(:immediate `((immediate-rescan ,stream)))
((nil) nil))
(values))))))
(define-input-editor-command (com-ie-rubout :type delete)
(stream input-buffer numeric-argument)
(ie-rub-del stream input-buffer (- numeric-argument)))
(define-input-editor-command (com-ie-delete-character :type delete)
(stream input-buffer numeric-argument)
(ie-rub-del stream input-buffer numeric-argument))
(define-input-editor-command (com-ie-rubout-word :type kill)
(stream input-buffer numeric-argument)
(ie-rub-del-word stream input-buffer (- numeric-argument)))
(define-input-editor-command (com-ie-delete-word :type kill)
(stream input-buffer numeric-argument)
(ie-rub-del-word stream input-buffer numeric-argument))
(define-input-editor-command (com-ie-clear-input :type kill)
(stream input-buffer)
;; Just push a copy of the input buffer onto the kill ring, no merging
(ie-kill stream input-buffer t 0 (fill-pointer input-buffer)))
(define-input-editor-command (com-ie-kill-line :type kill)
(stream input-buffer numeric-argument)
(let* ((reverse-p (minusp numeric-argument))
(point (insertion-pointer stream))
(other-point (if reverse-p
(ie-line-start input-buffer point)
(ie-line-end input-buffer point))))
(ie-kill stream input-buffer
(if (eql (slot-value stream 'last-command-type) 'kill) :merge t)
point
other-point
reverse-p)))
(define-input-editor-command (com-ie-make-room)
(stream input-buffer)
(let ((point (insertion-pointer stream))
(end (fill-pointer input-buffer)))
(cond ((= point end)
(incf (fill-pointer input-buffer)))
(t
(erase-input-buffer stream point)
(shift-buffer-portion input-buffer point (1+ point))))
(setf (aref input-buffer point) #\Newline)
(redraw-input-buffer stream point)))
(define-input-editor-command (com-ie-transpose-characters)
(stream input-buffer)
(let* ((start-position (min (1+ (insertion-pointer stream))
(fill-pointer input-buffer)))
(this-position (forward-or-backward input-buffer start-position t #'true))
(prev-position (forward-or-backward input-buffer this-position t #'true)))
(cond ((and this-position prev-position (/= this-position prev-position))
(let ((this-char (aref input-buffer this-position))
(prev-char (aref input-buffer prev-position)))
(erase-input-buffer stream prev-position)
(setf (aref input-buffer prev-position) this-char)
(setf (aref input-buffer this-position) prev-char)
(redraw-input-buffer stream prev-position)))
(t (beep stream)))))
(defun ie-kill (stream input-buffer kill-ring start end &optional reverse)
(when (< end start) (rotatef start end))
(when kill-ring
(let* ((top (and (eql kill-ring ':merge)
(eql *kill-ring-application* *application-frame*)
(history-top-element *kill-ring*)))
(length (if top (length top) 0)))
(setq *kill-ring-application* *application-frame*)
(do-input-buffer-pieces (input-buffer :start start :end end)
(start end noise-string)
:normal (incf length (- end start))
:noise-string (incf length (length (noise-string-display-string noise-string))))
(let ((new-top (make-string length))
(index 0))
(when top
(cond (reverse
;; Even when we're deleting backwards, we want to merge the
;; kills so they come out in the original order
(replace new-top top
:start1 (- length (length top)))
(setq index 0))
(t
(replace new-top top)
(setq index (length top)))))
(do-input-buffer-pieces (input-buffer :start start :end end)
(start end noise-string)
:normal (replace new-top input-buffer
:start1 index :end1 (incf index (- end start))
:start2 start :end2 end)
:noise-string (let ((string (noise-string-display-string noise-string)))
(replace new-top string
:start1 index :end1 (incf index (length string)))))
(cond (top
(setf (history-top-element *kill-ring*) new-top)
#+Genera (genera-kill-ring-save new-top t))
(t
(push-history-element *kill-ring* new-top)
#+Genera (genera-kill-ring-save new-top nil))))))
;; Erase what used to be there, side effect the input buffer, then redraw it
(erase-input-buffer stream start)
(if end
(shift-buffer-portion input-buffer end start)
(setf (fill-pointer input-buffer) start))
;; The insertion-pointer started out at either start or end, they're the same now
(setf (insertion-pointer stream) start)
;; Make sure the scan pointer doesn't point past the insertion pointer
(MINF (INPUT-POSITION STREAM) (INSERTION-POINTER STREAM))
(redraw-input-buffer stream)
;; This can be called in a loop, so reflect the kill operation now
(setf (slot-value stream 'last-command-type) 'kill))
References:
Main Index |
Thread Index