diff --git a/Goatee/buffer.lisp b/Goatee/buffer.lisp index 2d722ac..d39d16f 100644 --- a/Goatee/buffer.lisp +++ b/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))) diff --git a/Goatee/clim-area.lisp b/Goatee/clim-area.lisp index fd86d90..983ba63 100644 --- a/Goatee/clim-area.lisp +++ b/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 diff --git a/Goatee/conditions.lisp b/Goatee/conditions.lisp index 380c593..78e41bd 100644 --- a/Goatee/conditions.lisp +++ b/Goatee/conditions.lisp @@ -18,5 +18,5 @@ (in-package :goatee) -(define-condition goatee-error (error) +(define-condition goatee-error (simple-error) ()) diff --git a/Goatee/editing-stream.lisp b/Goatee/editing-stream.lisp index 9a589d5..1857853 100644 --- a/Goatee/editing-stream.lisp +++ b/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)))) \ No newline at end of file diff --git a/frames.lisp b/frames.lisp index 6624269..e552e6b 100644 --- a/frames.lisp +++ b/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 diff --git a/input-editing.lisp b/input-editing.lisp index 4bc534b..1951ec6 100644 --- a/input-editing.lisp +++ b/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) diff --git a/presentations.lisp b/presentations.lisp index 16b681b..b21803d 100644 --- a/presentations.lisp +++ b/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)) diff --git a/stream-output.lisp b/stream-output.lisp index 3315ef1..8015a70 100644 --- a/stream-output.lisp +++ b/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))