Fixed a bug in frame-input-context-track-pointer that was causing a

draw-rectangle* call on every motion event.

The vertical spacing for standard-extended-output-stream was, in
effect, being added twice to start dimensions for each line.  After fixing
that, plus some stuff in Goatee/clim-area.lisp, input editing regions
line up with other text on the same line.

Implemented replace-input, presentation-replace-input, and
write-token.

Implemented the input-sensitizer argument to with-input-editing.

Accept now replaces input editing text with input from button gestures
and makes the (now uneditable) input editing text sensitive as a
presentation.

In Goatee:
Beefed up buffer-close-line* to be able to delete lines backwards as
well, simplifying delete-char in the process.

Goatee/buffer.lisp

@@ -201,28 +201,33 @@
     (setf (point* buffer) (values line pos)))
   nil)
 
-(defgeneric buffer-close-line* (buffer line)
-  (:documentation "Delete the newline at the end of line, bring the
-  following line's contents onto line, and delete the following line"))
-
-(defmethod buffer-close-line* ((buffer basic-buffer-mixin) line)
-  (unless (typep line 'dbl-list)
-    (error 'buffer-bounds-error :buffer buffer :line nil :pos 0))
-  (let ((next-line (next line))
-	(line-size (size line)))
-    (if (eql (char-ref line (1- line-size)) #\Newline)
-	(progn
-	  (delete-char line 1 :position (1- (size line)))
-	  (decf (slot-value buffer 'size))
-	  (when next-line
-	    (loop for i from 0 below (size next-line)
-		  for j from (size line)
-		  do (insert line (char-ref next-line i) :position j))
-	    (dbl-remove next-line))
-	  (setf (tick line) (incf (tick buffer)))
-	  (values line (1- line-size)))
-	(error 'buffer-bounds-error
-	       :buffer buffer :line line :pos line-size))))
+(defgeneric buffer-close-line* (buffer line direction)
+  (:documentation "If DIRECTION is positive, elete the newline at the
+  end of line, bring the following line's contents onto line, and
+  delete the following line.  If DIRECTION is negative, first move back
+  one line, then do the deletion." ))
+
+(defmethod buffer-close-line* ((buffer basic-buffer-mixin) line direction)
+  (multiple-value-bind (this-line next-line)
+      (if (> 0 direction)
+	  (values line (next line))
+	  (values (prev line) line))
+    (unless (typep this-line 'dbl-list)
+      (error 'buffer-bounds-error :buffer buffer :line nil :pos 0))
+    (let ((line-size (size this-line)))
+      (if (eql (char-ref line (1- line-size)) #\Newline)
+	  (progn
+	    (delete-char line 1 :position (1- line-size))
+	    (decf (slot-value buffer 'size))
+	    (when next-line
+	      (loop for i from 0 below (size next-line)
+		    for j from (1- line-size)
+		    do (insert this-line (char-ref next-line i) :position j))
+	      (dbl-remove next-line))
+	    (setf (tick this-line) (incf (tick buffer)))
+	    (values this-line (1- line-size)))
+	  (error 'buffer-bounds-error
+		 :buffer buffer :line line :pos line-size)))))
 
 (defgeneric buffer-delete-char* (buffer line pos n)
   (:documentation "Delete characters from a line.  Can not delete the final
@@ -261,7 +266,7 @@
 		   (when (> del-chars 0)
 		     (buffer-delete-char* buf line pos (1- del-chars)))
 		   ;; Up against the end, this should signal an error
-		   (buffer-close-line* buf line)
+		   (buffer-close-line* buf line 1)
 		   (decf remaining del-chars))
 	      finally (buffer-delete-char* buf line pos remaining))
 	(loop with remaining = (- n)
@@ -270,7 +275,7 @@
 		   (buffer-delete-char* buf line pos (- pos))
 		   (decf remaining pos)
 		   (setf (values line pos)
-			 (buffer-close-line* buf (prev line))))
+			 (buffer-close-line* buf line -1)))
 	      finally (setf (values line pos)
 			    (buffer-delete-char* buf line pos (- remaining)))))
     (setf (point* buf) (values line pos)))

Goatee/clim-area.lisp

@@ -35,7 +35,9 @@
   (call-next-method))
 
 (defmethod climi::cursor-height ((cursor screen-area-cursor))
-  (ascent (screen-line cursor)))
+  (let ((line (screen-line cursor)))
+    (+ (ascent line) (descent line))))
+
 
 (defclass screen-line (editable-area-line displayed-output-record rectangle)
   ((current-contents :accessor current-contents :initarg :current-contents

Goatee/conditions.lisp

@@ -18,5 +18,5 @@
 
 (in-package :goatee)
 
-(define-condition goatee-error (error)
+(define-condition goatee-error (simple-error)
   ())

Goatee/editing-stream.lisp

@@ -102,3 +102,68 @@
 	  (replace stream-buffer snapshot-buffer
 		   :start1 first-mismatch
 		   :start2 first-mismatch)))))))
+
+(defmethod climi::finalize ((stream goatee-input-editing-mixin)
+			    input-sensitizer)
+  (setf (cursor-visibility (cursor (area stream))) nil)
+  (when input-sensitizer
+    (let ((real-stream (encapsulating-stream-stream stream)))
+      (funcall input-sensitizer
+	       real-stream
+	       #'(lambda ()
+		   (let ((record (area stream)))
+		     (delete-output-record record
+					   (output-record-parent record))
+		     (stream-add-output-record real-stream record)))))))
+
+;;; Hopefully only used on small buffers.
+
+(defun offset-location* (buffer offset)
+  (loop for line = (dbl-head (lines buffer)) then (next line)
+	for size = (and line (size line))
+	while line
+	summing size into total-offset
+	do (when (>= total-offset offset)
+	     (let ((pos (- size (- total-offset offset))))
+	       (if (> pos (line-last-point line))
+		   (return (values (next line) 0))
+		   (return (values line pos)))))
+	finally (error 'goatee-error
+		       :format-control "Offset ~S is greater than the ~
+  size of buffer ~S"
+		       :format-arguments (list offset buffer))))
+
+(defmethod replace-input ((stream goatee-input-editing-mixin) new-input
+			  &key
+			  (start 0)
+			  (end (length new-input))
+			  (buffer-start nil buffer-start-supplied-p)
+			  (rescan nil))
+  (unless buffer-start-supplied-p
+    (if (eq stream climi::*current-input-stream*)
+	(setq buffer-start climi::*current-input-position*)
+	(setq buffer-start 0)))
+  (let* ((scan-pointer (stream-scan-pointer stream))
+	 (area (area stream))
+	 (buf (buffer area))
+	 (del-chars (- scan-pointer buffer-start)))
+    (if (<= 0 del-chars)
+	(if (mismatch (stream-input-buffer stream) new-input
+		      :start1 buffer-start :end1 scan-pointer
+		      :start2 start :end2 end)
+	    (multiple-value-bind (line pos)
+		(offset-location* buf buffer-start)
+	      (when (> del-chars 0)
+		(delete-char buf del-chars :line line :pos pos))
+	      ;; location should be preserved across the delete-char, but it
+	      ;; would be safest to use a buffer pointer or something...
+	      (insert buf new-input :line line :pos pos :start start :end end)
+	      (redisplay-area area)
+	      (queue-rescan stream))
+	    (when rescan
+	      (queue-rescan stream)))
+	(warn "replace-input stream ~S: buffer-start ~S is greater than ~
+               scan-pointer ~S.  Don't know how to deal with that."
+	      stream
+	      buffer-start
+	      scan-pointer))))

frames.lisp

@@ -659,12 +659,14 @@ FRAME-EXIT condition."))
 	    (highlight-presentation-1 (car (frame-hilited-presentation frame))
 				      (cdr (frame-hilited-presentation frame))
 				      :unhighlight))
-	  (when presentation
-	    (setf (frame-hilited-presentation frame)
-		  (cons presentation stream))
-	    (highlight-presentation-1 presentation
-				      stream
-				      :highlight)))))
+	  (if presentation
+	      (when (not (eq presentation
+			     (car (frame-hilited-presentation frame))))
+		(setf (frame-hilited-presentation frame)
+		      (cons presentation stream))
+		(highlight-presentation-1 presentation stream :highlight))
+	      (setf (frame-hilited-presentation frame) nil)))))
+
 
 (defun simple-event-loop ()
   "An simple event loop for applications that want all events to be handled by

input-editing.lisp

@@ -20,9 +20,6 @@
 
 (in-package :CLIM-INTERNALS)
 
-;;; Stub of input editing so we can see what we're doing and make
-;;; progress on ACCEPT
-
 (defvar *activation-gestures* nil)
 (defvar *standard-activation-gestures* '(:newline :return))
 
@@ -140,6 +137,10 @@
 (define-condition rescan-condition (condition)
   ())
 
+(defgeneric finalize (editing-stream input-sensitizer)
+  (:documentation "Do any cleanup on an editing stream, like turning off the
+  cursor, etc."))
+
 (defgeneric invoke-with-input-editing
     (stream continuation input-sensitizer initial-contents class))
 
@@ -148,18 +149,20 @@
 				      input-sensitizer
 				      initial-contents
 				      class)
-  (declare (ignore input-sensitizer))
   (let ((editing-stream (make-instance class
 				       :stream stream
 				       :initial-contents initial-contents)))
-    (loop
-     (block rescan
-       (handler-bind ((rescan-condition #'(lambda (c)
-					    (declare (ignore c))
-					    (reset-scan-pointer editing-stream)
-					    (return-from rescan nil))))
-	 (return-from invoke-with-input-editing
-	   (funcall continuation editing-stream)))))))
+    (unwind-protect
+	 (loop
+	  (block rescan
+	    (handler-bind ((rescan-condition #'(lambda (c)
+						 (declare (ignore c))
+						 (reset-scan-pointer
+						  editing-stream)
+						 (return-from rescan nil))))
+	      (return-from invoke-with-input-editing
+		(funcall continuation editing-stream)))))
+      (finalize editing-stream input-sensitizer))))
 
 (defmethod invoke-with-input-editing
     (stream continuation input-sensitizer initial-contents class)
@@ -234,6 +237,23 @@
   (declare (ignore format-string format-args))
   nil)
 
+;;; Defaults for replace-input and presentation-replace-input.
+
+(defvar *current-input-stream* nil)
+(defvar *current-input-position* 0)
+
+(defmacro with-input-position ((stream) &body body)
+  (let ((stream-var (gensym "STREAM")))
+    `(let* ((,stream-var ,stream)
+	    (*current-input-stream* (and (typep ,stream-var
+						'input-editing-stream)
+					 ,stream-var))
+	    (*current-input-position* (and *current-input-stream*
+					   (stream-scan-pointer ,stream-var))))
+       ,@body)))
+
+(defgeneric replace-input (stream new-input
+			   &key start end buffer-start rescan))
 
 (defun read-token (stream &key
 		   (input-wait-handler *input-wait-handler*)
@@ -273,6 +293,14 @@
 		    (unread-gesture gesture :stream stream)
 		    (return (subseq result 0))))))
 
+(defun write-token (token stream &key acceptably)
+  (let ((put-in-quotes (and acceptably (some #'delimiter-gesture-p token))))
+    (when put-in-quotes
+      (write-char #\" stream))
+    (write-string token stream)
+    (when put-in-quotes
+      (write-char #\" stream))))
+
 ;;; Signalling Errors Inside present (sic)
 
 (define-condition simple-parse-error (simple-condition parse-error)

presentations.lisp

@@ -1237,6 +1237,20 @@ function lambda list"))
 	    (values string (fill-pointer string))
 	    result)))))
 
+(defmethod presentation-replace-input
+    ((stream input-editing-stream) object type view
+     &key (buffer-start nil buffer-start-supplied-p)
+     (rescan nil rescan-supplied-p)
+     query-identifier for-context-type)
+  (let ((result (present-to-string object type
+				   :view view :acceptably t
+				   :for-context-type for-context-type)))
+    (apply #'replace-input stream result `(,@(and buffer-start-supplied-p
+						  `(:buffer-start
+						    ,buffer-start))
+					   ,@(and rescan-supplied-p
+						  `(:rescan ,rescan))))))
+
 ;;; Context-dependent input
 ;;; An input context is a cons of a presentation type and a continuation to
 ;;; call to return a presentation to that input context.
@@ -1428,38 +1442,49 @@ function lambda list"))
             :additional-activation-gestures may be passed to accept."))
   (unless (or activationsp additional-activations-p *activation-gestures*)
     (setq activation-gestures *standard-activation-gestures*))
-  (with-input-context (type)
-    (object object-type event options)
-    (with-input-editing (stream)
-      (with-activation-gestures ((if additional-activations-p
-				     additional-activation-gestures
-				     activation-gestures)
-				 :override activationsp)
-	(multiple-value-bind (object object-type)
-	    (apply-presentation-generic-function accept
-						 type
-						 stream
-						 view
-						 `(,@(and defaultp
-							  `(:default ,default))
-						   ,@(and default-type-p
-							  `(:default-type
-							    ,default-type))))
-	  ;; Eat trailing activation gesture
-	  ;; XXX what about pointer gestures?
-	  (unless *recursive-accept-p*
-	    (let ((ag (read-char-no-hang stream nil stream t)))
-	      (when (and ag
-			 (not (eq ag stream))
-			 (activation-gesture-p ag)))
-	      (unless (or (null ag)
-			  (eq ag stream))
-		(unless (activation-gesture-p ag)
-		  (unread-char ag stream)))))
-	  (values object (or object-type type)))))
-    ;; A presentation was clicked on, or something
-    (t
-     (values object object-type))))
+  (let ((sensitizer-object nil)
+	(sensitizer-type nil))
+    (with-input-editing
+	(stream
+	 :input-sensitizer #'(lambda (stream cont)
+			       (with-output-as-presentation
+				   (stream sensitizer-object sensitizer-type)
+				 (funcall cont))))
+      (with-input-position (stream)
+	(setf (values sensitizer-object sensitizer-type)
+	      (with-input-context (type)
+		(object object-type event options)
+		(with-activation-gestures ((if additional-activations-p
+					       additional-activation-gestures
+					       activation-gestures)
+					   :override activationsp)
+		  (multiple-value-bind (object object-type)
+		      (apply-presentation-generic-function
+		       accept
+		       type stream view
+		       `(,@(and defaultp `(:default ,default))
+			 ,@(and default-type-p `(:default-type ,default-type))))
+		    ;; Eat trailing activation gesture
+		    ;; XXX what about pointer gestures?
+		    (unless *recursive-accept-p*
+		      (let ((ag (read-char-no-hang stream nil stream t)))
+			(when (and ag
+				   (not (eq ag stream))
+				   (activation-gesture-p ag)))
+			(unless (or (null ag) (eq ag stream))
+			  (unless (activation-gesture-p ag)
+			    (unread-char ag stream)))))
+		    (values object (or object-type type))))
+		;; A presentation was clicked on, or something
+		(t
+		 (when (getf options :echo t)
+		   (presentation-replace-input stream object object-type view
+					       :rescan nil))
+		 (values object object-type))))
+	;; Just to make it clear...
+	(values sensitizer-object sensitizer-type)))))
+
+
 
 (defgeneric prompt-for-accept (stream type view &key))
 

stream-output.lisp

@@ -259,7 +259,7 @@ than one line of output."))
   (with-slots (baseline vspace) stream
      (multiple-value-bind (cx cy) (stream-cursor-position stream)
        (draw-text* (sheet-medium stream) line
-                   cx (+ cy baseline vspace)))))
+                   cx (+ cy baseline)))))
 
 (defmethod stream-write-char ((stream standard-extended-output-stream) char)
   (let* ((cursor (stream-text-cursor stream))