Implemented :ALIGN-PROMPTS in ACCEPTING-VALUES. This was harder than

it sounds, requiring several changes and cleanups:

Moved the call to PROMPT-FOR-ACCEPT from ACCEPT to STREAM-ACCEPT. The
spec vaguely hints that ACCEPT is responsible for drawing the prompt,
but that makes things like wrapping the calls to PROMPT-FOR-ACCEPT
and ACCEPT-PRESENT-DEFAULT inside a table formatting directive hard
to do. This shouldn't affect any user code.

Made Goatee input streams play nice with output recording. Added the
notion of a NEWLINE-CHARACTER to Goatee buffers; NIL is valid, so one
can construct Goatee areas that will only have one line. This
eliminates a lot of ugliness from ACCEPTING-VALUES dialogs.

Fixed a few Goatee bugs.

Goatee/buffer.lisp

@@ -56,11 +56,16 @@
   and delete operations on a buffer of text (generally)."))
 
 (defclass basic-buffer-mixin (basic-buffer)
-  ((lines :accessor lines :initarg :lines
-	  :initform (make-instance 'dbl-list-head))
-   (tick :accessor tick :initarg :tick :initform 0)
-
-   (size :reader size :initform 0)))
+  ((lines :accessor lines :initarg :lines)
+   (tick :accessor tick :initarg :tick)
+   (size :reader size :initform 0)
+   (newline-character :accessor newline-character :initarg :newline-character
+		      :documentation "The character that ends a line. NIL means
+   that the buffer will only have one line."))
+  (:default-initargs
+    :lines (make-instance 'dbl-list-head)
+    :tick 0
+    :newline-character #\Newline))
 
 (define-condition buffer-bounds-error (goatee-error)
   ((buffer :reader buffer-bounds-error-buffer :initarg :buffer :initform nil)
@@ -124,7 +129,7 @@
 			 :tick (incf (tick buf)))))
 	  ;; delete to end of line
 	  (delete-char line (- (size line) pos) :position pos)
-	  (insert line #\newline :position pos)
+	  (insert line (newline-character buf) :position pos)
 	  (setf (tick line) (incf (tick buf)))
 	  (dbl-insert-after new-line line)
 	  (incf (slot-value buf 'size))
@@ -170,8 +175,9 @@
 	  (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 this-line (1- line-size)) #\Newline)
+    (let ((line-size (size this-line))
+	  (newline-character (newline-character buffer)))
+      (if (eql (char-ref this-line (1- line-size)) newline-character)
 	  (progn
 	    (delete-char this-line 1 :position (1- line-size))
 	    (decf (slot-value buffer 'size))
@@ -387,7 +393,7 @@
   be kept in \"display\" order." )))
 
 (defmethod make-buffer-line ((buffer extent-buffer-mixin) &rest initargs)
-  (apply #'make-instance 'extent-buffer-line initargs))
+  (apply #'make-instance 'extent-buffer-line :buffer buffer initargs))
 
 (defmethod record-extent-lines ((extent extent))
   (loop for line = (line (bp-start extent)) then (next line)
@@ -474,8 +480,9 @@
   (let* ((size (size line))
 	 (last-char (if (> size 0)
 			(char-ref line (1- size))
-			nil)))
-    (cond ((and last-char (char= last-char #\Newline))
+			nil))
+	 (newline-char (newline-character (buffer line))))
+    (cond ((and last-char newline-char (char= last-char newline-char))
 	   (1- size))
 	  (t size))))
 

Goatee/clim-area.lisp

@@ -30,7 +30,8 @@
 
 (defmethod* (setf cursor-position) (nx ny (cursor screen-area-cursor))
   (declare (ignore nx ny))
-  (when (cursor-state cursor)
+  (when (and (cursor-state cursor)
+	     (stream-drawing-p (cursor-sheet cursor)))
     (error "screen-area-cursor ~S must not be visible when position is
   set"
 	   cursor))
@@ -108,6 +109,19 @@
 	  for char = (char-ref line i)
 	  sum (text-size stream char :text-style text-style))))
 
+(defmethod* (setf output-record-position) :around
+  (nx ny (record simple-screen-area))
+  (multiple-value-bind (x y)
+      (output-record-position record)
+    (multiple-value-prog1
+	(call-next-method)
+      (let ((cursor (cursor record)))
+	(multiple-value-bind (cx cy)
+	    (cursor-position cursor)
+	  (setf (cursor-position cursor)
+		(values (+ cx (- nx x))
+			(+ cy (- ny y)))))))))
+
 (defclass screen-line (editable-area-line displayed-output-record
 					  climi::basic-output-record)
   ((current-contents :accessor current-contents :initarg :current-contents
@@ -119,7 +133,9 @@
    be, on the screen.  This does not include the buffer line's newline")
    (ascent :accessor ascent :initarg :ascent)
    (descent :accessor descent :initarg :descent)
-   (baseline :accessor baseline :initarg :baseline)
+   (baseline :accessor baseline :initarg :baseline
+	     :documentation "The y coordinate of the line's
+ baseline. This is an absolute coordinate, not relative to the output record.")
    (width :accessor width :initarg :width)
    (cursor :accessor cursor :initarg :cursor :initform nil)
    (line-breaks :accessor line-breaks :initform nil)))
@@ -131,6 +147,16 @@
       (format stream "X ~S:~S Y ~S:~S " x1 x2 y1 y2)
       (write (current-contents obj) :stream stream))))
 
+(defmethod (setf output-record-position) :around
+    (nx ny (record screen-line))
+  (declare (ignore nx))
+  (multiple-value-bind (x y)
+      (output-record-position record)
+    (declare (ignore x))
+    (multiple-value-prog1
+	(call-next-method)
+      (incf (baseline record) (- ny y)))))
+
 (defmethod (setf width) :after (width (line screen-line))
   (setf (slot-value line 'climi::x2) (+ (slot-value line 'climi::x1) width)))
 
@@ -142,6 +168,10 @@
 
 (defun line-contents-sans-newline (buffer-line &key destination)
   (let* ((contents-size (line-last-point buffer-line)))
+    ;; XXX Should check entire string for "non-printable" characters
+    (when (and (> contents-size 0)
+	       (eql (char-ref buffer-line (1- contents-size)) #\Newline))
+      (decf contents-size))
     (if (zerop contents-size)
 	(if destination
 	    (progn

Goatee/editable-buffer.lisp

@@ -91,7 +91,7 @@
 	 (line (line pt))
 	 (pos (pos pt)))
     ;; point is updated by bp-buffer-mixin methods.
-    (if (eql c #\Newline)
+    (if (eql c (newline-character buffer))
 	      (buffer-open-line* buffer line pos)
 	      (buffer-insert* buffer c line pos))))
 
@@ -103,20 +103,21 @@
 	 (setf (point* buffer) (values line pos))))
   (multiple-value-bind (line pos)
       (point* buffer)
-    (loop for search-start = start then (1+ found-newline)
-	  for found-newline = (position #\Newline s
-					:start search-start
-					:end end)
-	  while found-newline
-	  do (progn
-	       (setf (values line pos)
-		     (buffer-insert* buffer s line pos
+    (loop
+       with newline-character = (newline-character buffer)
+       for search-start = start then (1+ found-newline)
+       for found-newline = (position newline-character s
 				     :start search-start
-				     :end found-newline))
-	       (setf (values line pos)
-		     (buffer-open-line* buffer line pos)))
-	  finally (return (buffer-insert* buffer s line pos
-					  :start search-start :end end)))))
+				     :end end)
+       while found-newline
+       do (progn
+	    (setf (values line pos)
+		  (buffer-insert* buffer s line pos
+				  :start search-start
+				  :end found-newline))
+	    (setf (values line pos) (buffer-open-line* buffer line pos)))
+       finally (return (buffer-insert* buffer s line pos
+				       :start search-start :end end)))))
 
 (defmethod delete-char ((buf editable-buffer) &optional (n 1)
 			&key position line (pos 0))

Goatee/editing-stream.lisp

@@ -55,31 +55,37 @@
 				       &key stream (initial-contents "")
 				       (cursor-visibility t)
 				       (background-ink
-					(medium-background stream)))
+					(medium-background stream))
+				       single-line)
   (multiple-value-bind (cx cy)
       (stream-cursor-position stream)
     (let ((max-width (- (stream-text-margin stream) cx)))
       ;; XXX hack to give area a fixed size rectangle that can be highlighted
-      (with-output-recording-options (stream :draw t :record t)
+      (with-output-recording-options (stream :record t)
 	(draw-rectangle* stream cx cy
 			 (+ cx max-width) (+ cy (stream-line-height stream))
 			 :ink background-ink
 			 :filled t))
-      (climi::with-keywords-removed (args (:initial-contents))
+      (climi::with-keywords-removed (args (:initial-contents :single-line))
 	(setf (area obj)
 	      (apply #'make-instance
 		     'simple-screen-area
 		     :area-stream stream
 		     :buffer (make-instance 'editable-buffer
-					    :initial-contents initial-contents)
+					    :initial-contents
+					    initial-contents
+					    :newline-character (if single-line
+								   nil
+								   #\Newline))
 		     :x-position cx
 		     :y-position cy
 		     :cursor-visibility cursor-visibility
 		     :max-width max-width
 		     :allow-other-keys t
 		     args)))
+      ;; XXX Really add it here?
       (stream-add-output-record stream (area obj))
-      (redisplay-area (area obj))
+      #+nil (redisplay-area (area obj))
       ;; initialize input-editing-stream state to conform to our reality
       (make-input-editing-stream-snapshot obj (area obj)))))
 

dialog.lisp

@@ -67,7 +67,9 @@ accept of this query")))
 
 (defclass accepting-values-stream (standard-encapsulating-stream)
   ((queries :accessor queries :initform nil)
-   (selected-query :accessor selected-query :initform nil)))
+   (selected-query :accessor selected-query :initform nil)
+   (align-prompts :accessor align-prompts :initarg :align-prompts
+		  :initform nil)))
 
 (defmethod stream-default-view ((stream accepting-values-stream))
   +textual-dialog-view+)
@@ -127,13 +129,18 @@ accept of this query")))
      (command-table 'accepting-values)
      (frame-class 'accept-values))
   (declare (ignore own-window exit-boxes modify-initial-query
-    resize-frame align-prompts label scroll-bars x-position y-position
+    resize-frame label scroll-bars x-position y-position
     width height frame-class))
-  (let* ((*accepting-values-stream* (make-instance 'accepting-values-stream
-						  :stream stream))
+  (let* ((*accepting-values-stream*
+	  (make-instance 'accepting-values-stream
+			 :stream stream
+			 :align-prompts align-prompts))
 	 (arecord (updating-output (stream
 				    :record-type 'accepting-values-record)
-		    (funcall body *accepting-values-stream*)
+		    (if align-prompts
+			(formatting-table (stream)
+			  (funcall body *accepting-values-stream*))
+			(funcall body *accepting-values-stream*))
 		    (display-exit-boxes *application-frame*
 					stream
 					(stream-default-view
@@ -205,7 +212,8 @@ accept of this query")))
   (declare (ignore activation-gestures additional-activation-gestures
 		   delimiter-gestures additional-delimiter-gestures))
   (let ((query (find query-identifier (queries stream)
-		     :key #'query-identifier :test #'equal)))
+		     :key #'query-identifier :test #'equal))
+	(align (align-prompts stream)))
     (unless query
       (setq query (make-instance 'query
 				 :query-identifier query-identifier
@@ -220,20 +228,33 @@ accept of this query")))
     (unless (equal default (default query)) 
       (setf (default query) default)
       (setf (value query) default))
-    (let ((query-record (funcall-presentation-generic-function
-			 accept-present-default
-			 type (encapsulating-stream-stream stream) view
-			 (value query)
-			 default-supplied-p
-			 nil query-identifier)))
-      (setf (record query) query-record)
-      (when (accept-condition query)
-	(signal (accept-condition query)))
-      (multiple-value-prog1
-	  (values (value query) (ptype query) (changedp query))
-	(setf (default query) default)
-	(setf (ptype query) type)
-	(setf (changedp query) nil)))))
+    (flet ((do-prompt ()
+	     (apply #'prompt-for-accept stream type view rest-args))
+	   (do-accept-present-default ()
+	     (funcall-presentation-generic-function
+	      accept-present-default
+	      type (encapsulating-stream-stream stream) view
+	      (value query)
+	      default-supplied-p nil query-identifier)))
+      (let ((query-record nil))
+	(if align
+	    (formatting-row (stream)
+	      (formatting-cell (stream :align-x align)
+		(do-prompt))
+	      (formatting-cell (stream)
+		(setq query-record (do-accept-present-default))))
+	    (progn
+	      (do-prompt)
+	      (setq query-record (do-accept-present-default))))
+	(setf (record query) query-record)
+	(when (accept-condition query)
+	  (signal (accept-condition query)))
+	(multiple-value-prog1
+	    (values (value query) (ptype query) (changedp query))
+	  (setf (default query) default)
+	  (setf (ptype query) type)
+	  (setf (changedp query) nil))))))
+
 
 (defmethod prompt-for-accept ((stream accepting-values-stream)
 			      type view
@@ -339,7 +360,8 @@ is called. Used to determine if any editing has been done by user")))
 			     (make-instance 'standard-input-editing-stream
 					    :stream stream
 					    :cursor-visibility nil
-					    :background-ink +grey90+))))
+					    :background-ink +grey90+
+					    :single-line t))))
 		   (when default-supplied-p
 		     (input-editing-rescan-loop ;XXX probably not needed
 		      editing-stream
@@ -403,12 +425,16 @@ is called. Used to determine if any editing has been done by user")))
 			   :rescan t)))
 	(setf (cursor-visibility estream) t)
 	(setf (snapshot record) (copy-seq stream-input-buffer))
-	(handler-case
-	    (av-do-accept query record)
-	  (condition (c)
-	    (format *trace-output* "accepting-values accept condition: ~A~%"
-		    c)
-	    (setf (accept-condition query) c)))))))
+	(block accept-condition-handler
+	  (handler-bind ((condition #'(lambda (c)
+					(format *trace-output*
+						"accepting-values accept condition: ~A~%"
+						c)
+					(setf (accept-condition query) c)
+					(return-from accept-condition-handler
+					  c))))
+	    (av-do-accept query record)))))))
+
 
 
 (defmethod deselect-query (stream query (record av-text-record))

incremental-redisplay.lisp

@@ -1113,7 +1113,8 @@ records. "))
 	(call-next-method)
       ;; coordinate= here instead?
       (unless (and (= x nx) (= y ny))
-	(let ((stream (slot-value  record 'stream))
+	(let ((stream (and (slot-exists-p record 'stream)
+			   (slot-value  record 'stream)))
 	      (parent (output-record-parent record)))
 	  (when (and stream parent)
 	    (note-output-record-child-changed

input-editing.lisp

@@ -240,6 +240,7 @@
   (let ((editing-stream (make-instance class
 				       :stream stream
 				       :initial-contents initial-contents)))
+    (goatee::redisplay-area (goatee::area editing-stream))
     (unwind-protect
 	 (loop
 	  (block rescan

presentation-defs.lisp

@@ -670,7 +670,6 @@ call-next-method to get the \"real\" answer based on the stream type."))
       ;; behavior of temporarily putting the default on the history
       ;; stack so the user can conveniently suck it in.
       (flet ((do-accept (args)
-	       (apply #'prompt-for-accept stream real-type view args)
 	       (apply #'stream-accept stream real-type args))
 	     (get-history ()
 	       (when real-history-type
@@ -727,14 +726,16 @@ call-next-method to get the \"real\" answer based on the stream type."))
 
 (defmethod stream-accept ((stream standard-extended-input-stream) type
 			  &rest args
-			  &key
+			  &key (view (stream-default-view stream))
 			  &allow-other-keys)
+  (apply #'prompt-for-accept stream type view args)
   (apply #'accept-1 stream type args))
 
 (defmethod stream-accept ((stream standard-input-editing-stream) type
 			  &rest args
-			  &key
+			  &key (view (stream-default-view stream))
 			  &allow-other-keys)
+  (apply #'prompt-for-accept stream type view args)
   (apply #'accept-1 stream type args))
 
 (defmethod stream-accept ((stream #.*string-input-stream-class*) type