[slime-cvs] CVS update: slime/slime.el
Matthias Koeppe
mkoeppe at common-lisp.net
Thu Aug 4 19:19:46 UTC 2005
Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv25583
Modified Files:
slime.el
Log Message:
(slime-repl-insert-prompt): Accept a list of strings,
representing individual values of a multiple-value result. Mark
them up as separate presentations.
(reify-old-output): Support reifying individual values of a
multiple-value result.
(slime-pre-command-hook): Don't call
slime-presentation-command-hook.
(slime-post-command-hook): Don't call
slime-presentation-post-command-hook.
(slime-presentation-command-hook): Removed.
(slime-presentation-post-command-hook): Removed.
(slime-presentation-whole-p): New.
(slime-same-presentation-p): New.
(slime-presentation-start, slime-presentation-end): New.
(slime-presentation-around-point): New.
(slime-after-change-function): New.
(slime-setup-command-hooks): Install slime-after-change-function
as an after-change-function.
(slime-repl-enable-presentations): Make
slime-repl-presentation nonsticky.
(slime-mark-presentation-start, slime-mark-presentation-end): New
functions.
(slime-mark-presentation-start-handler): Renamed from
slime-mark-presentation-start.
(slime-mark-presentation-end-handler): Renamed from
slime-mark-presentation-end.
(slime-presentation): New structure.
(slime-add-presentation-properties): New function.
(slime-insert-presentation): New function.
Date: Thu Aug 4 21:19:43 2005
Author: mkoeppe
Index: slime/slime.el
diff -u slime/slime.el:1.516 slime/slime.el:1.517
--- slime/slime.el:1.516 Thu Aug 4 21:14:51 2005
+++ slime/slime.el Thu Aug 4 21:19:43 2005
@@ -868,15 +868,13 @@
"Execute all functions in `slime-pre-command-actions', then NIL it."
(dolist (undo-fn slime-pre-command-actions)
(ignore-errors (funcall undo-fn)))
- (setq slime-pre-command-actions nil)
- (slime-presentation-command-hook))
+ (setq slime-pre-command-actions nil))
(defun slime-post-command-hook ()
(when (and slime-mode (slime-connected-p))
(slime-process-available-input))
(when (null pre-command-hook) ; sometimes this is lost
- (add-hook 'pre-command-hook 'slime-pre-command-hook))
- (slime-presentation-post-command-hook) )
+ (add-hook 'pre-command-hook 'slime-pre-command-hook)))
(defun slime-setup-command-hooks ()
"Setup a buffer-local `pre-command-h'ook' to call `slime-pre-command-hook'."
@@ -884,7 +882,8 @@
(make-local-hook 'post-command-hook)
;; alanr: need local t
(add-hook 'pre-command-hook 'slime-pre-command-hook nil t)
- (add-hook 'post-command-hook 'slime-post-command-hook nil t))
+ (add-hook 'post-command-hook 'slime-post-command-hook nil t)
+ (add-hook 'after-change-functions 'slime-after-change-function nil t))
;(add-hook 'slime-mode-hook 'slime-setup-command-hooks)
;(setq post-command-hook nil)
@@ -2570,40 +2569,85 @@
(when (boundp 'text-property-default-nonsticky)
(pushnew '(slime-repl-old-output . t) text-property-default-nonsticky
:test 'equal)
+ (pushnew '(slime-repl-presentation . t) text-property-default-nonsticky
+ :test 'equal)
(pushnew '(slime-repl-result-face . t) text-property-default-nonsticky
:test 'equal)))
(make-variable-buffer-local
(defvar slime-presentation-start-to-point (make-hash-table)))
-(defun slime-mark-presentation-start (process string)
+(defun slime-mark-presentation-start (id)
+ (setf (gethash id slime-presentation-start-to-point)
+ (with-current-buffer (slime-output-buffer)
+ (marker-position (symbol-value 'slime-output-end)))))
+
+(defun slime-mark-presentation-start-handler (process string)
(if (and string (string-match "<\\([0-9]+\\)" string))
- (progn
- (let* ((match (substring string (match-beginning 1) (match-end 1)))
- (id (car (read-from-string match))))
- (setf (gethash id slime-presentation-start-to-point)
- (with-current-buffer (slime-output-buffer)
- (marker-position (symbol-value 'slime-output-end))))))))
+ (let* ((match (substring string (match-beginning 1) (match-end 1)))
+ (id (car (read-from-string match))))
+ (slime-mark-presentation-start id))))
+
+(defun slime-mark-presentation-end (id)
+ (let ((start (gethash id slime-presentation-start-to-point)))
+ (setf (gethash id slime-presentation-start-to-point) nil)
+ (when start
+ (with-current-buffer (slime-output-buffer)
+ (slime-add-presentation-properties start (symbol-value 'slime-output-end)
+ id nil)))))
-(defun slime-mark-presentation-end (process string)
+(defun slime-mark-presentation-end-handler (process string)
(if (and string (string-match ">\\([0-9]+\\)" string))
- (progn
- (let* ((match (substring string (match-beginning 1) (match-end 1)))
- (id (car (read-from-string match))))
- (let ((start (gethash id slime-presentation-start-to-point)))
- (setf (gethash id slime-presentation-start-to-point) nil)
- (when start
- (with-current-buffer (slime-output-buffer)
- (add-text-properties
- start (symbol-value 'slime-output-end)
- `(face slime-repl-result-face
- slime-repl-old-output ,id
- mouse-face slime-repl-output-mouseover-face
- keymap ,slime-presentation-map
- rear-nonsticky (slime-repl-old-output
- slime-repl-result-face
- slime-repl-output-mouseover-face))))))))))
+ (let* ((match (substring string (match-beginning 1) (match-end 1)))
+ (id (car (read-from-string match))))
+ (slime-mark-presentation-end id))))
+
+(defstruct (slime-presentation)
+ (text)
+ (id)
+ (start-p)
+ (stop-p))
+
+(defun slime-add-presentation-properties (start end id result-p)
+ "Make the text between START and END a presentation with ID.
+RESULT-P decides whether a face for a return value or output text is used."
+ (add-text-properties start end
+ `(face slime-repl-inputed-output-face
+ slime-repl-old-output ,id
+ mouse-face slime-repl-output-mouseover-face
+ keymap ,slime-presentation-map
+ rear-nonsticky (slime-repl-old-output
+ slime-repl-presentation
+ face mouse-face)))
+ (let ((text (buffer-substring-no-properties start end)))
+ (case (- end start)
+ (0)
+ (1
+ (add-text-properties start end
+ `(slime-repl-presentation
+ ,(make-slime-presentation :text text :id id
+ :start-p t :stop-p t))))
+ (t
+ (let ((inhibit-modification-hooks t))
+ (add-text-properties start (1+ start)
+ `(slime-repl-presentation
+ ,(make-slime-presentation :text text :id id
+ :start-p t :stop-p nil)))
+ (when (> (- end start) 2)
+ (add-text-properties (1+ start) (1- end)
+ `(slime-repl-presentation
+ ,(make-slime-presentation :text text :id id
+ :start-p nil :stop-p nil))))
+ (add-text-properties (1- end) end
+ `(slime-repl-presentation
+ ,(make-slime-presentation :text text :id id
+ :start-p nil :stop-p t))))))))
+(defun slime-insert-presentation (result output-id)
+ (let ((start (point)))
+ (insert result)
+ (slime-add-presentation-properties start (point) output-id t)))
+
(defun slime-open-stream-to-lisp (port)
(let ((stream (open-network-stream "*lisp-output-stream*"
(slime-with-connection-buffer ()
@@ -2619,8 +2663,8 @@
(install-bridge)
(setq bridge-destination-insert nil)
(setq bridge-source-insert nil)
- (setq bridge-handlers (list* '("<" . slime-mark-presentation-start)
- '(">" . slime-mark-presentation-end)
+ (setq bridge-handlers (list* '("<" . slime-mark-presentation-start-handler)
+ '(">" . slime-mark-presentation-end-handler)
bridge-handlers))
(set-process-coding-system stream
slime-net-coding-system
@@ -2756,61 +2800,105 @@
(slime-setup-command-hooks)
(run-hooks 'slime-repl-mode-hook))
-(defvar slime-not-copying-whole-presentation nil)
-
-;; alanr
-(defun slime-presentation-command-hook ()
- (let* ((props-here (text-properties-at (point)))
- (props-before (and (not (= (point) (point-min)))
- (text-properties-at (1- (point)))))
- (inside (and (getf props-here 'slime-repl-old-output)))
- (at-beginning (and inside
- (not (getf props-before 'slime-repl-old-output))))
- (at-end (and (or (= (point) (point-max))
- (not (getf props-here 'slime-repl-old-output)))
- (getf props-before 'slime-repl-old-output)))
- (start (cond (at-beginning (point))
- (inside (previous-single-property-change
- (point) 'slime-repl-old-output))
- (at-end (previous-single-property-change
- (1- (point)) 'slime-repl-old-output))))
- (end (cond (at-beginning (or (next-single-property-change
- (point) 'slime-repl-old-output)
- (point-max)))
- (inside (or (next-single-property-change (point) 'slime-repl-old-output)
- (point-max)))
- (at-end (point)))))
- ; (setq message (format "%s %s %s %s %s" at-beginning inside at-end start end))
- (when (and (or inside at-end) start end (> end start))
- (let ((kind (get this-command 'action-type)))
- ; (message (format "%s %s %s %s" at-beginning inside at-end kind))
- (cond ((and (eq kind 'inserts) inside (not at-beginning))
- (setq this-command 'ignore))
- ((and (eq kind 'deletes-forward) inside (not at-end))
- (kill-region start end)
- (setq this-command 'ignore))
- ((and (eq kind 'deletes-backward) (or inside at-end) (not at-beginning))
- (kill-region start end)
- (setq this-command 'ignore))
- ((eq kind 'copies)
- (multiple-value-bind (start end) (slime-property-bounds 'slime-repl-old-input)
- (setq slime-not-copying-whole-presentation
- (not (or (and at-beginning (>= (mark) end))
- (and at-end (<= (mark) start)))))))
- ;(message (format "%s %s" length (abs (- (point) (mark))))))))
- )))))
-
-;; if we did not copy the whole presentation, then remove the text properties from the
-;; top of the kill ring
-
-(defun slime-presentation-post-command-hook ()
- (when (eq (get this-command 'action-type) 'copies)
- (when slime-not-copying-whole-presentation
- (remove-text-properties 0 (length (car kill-ring))
- '(slime-repl-old-output t mouse-face t rear-nonsticky t)
- (car kill-ring))))
- (setq slime-not-copying-whole-presentation nil)
- )
+(defun slime-presentation-whole-p (start end)
+ (let ((presentation (get-text-property start 'slime-repl-presentation)))
+ (and presentation
+ (string= (buffer-substring-no-properties start end)
+ (slime-presentation-text presentation)))))
+
+(defun slime-same-presentation-p (a b)
+ (and (string= (slime-presentation-text a) (slime-presentation-text b))
+ (equal (slime-presentation-id a) (slime-presentation-id b))))
+
+(defun* slime-presentation-start ()
+ "Find start of presentation at point. Return buffer index and
+ whether a start-tag was found. When there is no presentation at
+ point, return nil and nil."
+ (let* ((presentation (get-text-property (point) 'slime-repl-presentation))
+ (this-presentation presentation))
+ (unless presentation
+ (return-from slime-presentation-start
+ (values nil nil)))
+ (save-excursion
+ (while (not (slime-presentation-start-p this-presentation))
+ (let ((change-point (previous-single-property-change (point) 'slime-repl-presentation)))
+ (unless change-point
+ (return-from slime-presentation-start
+ (values (point-min) nil)))
+ (setq this-presentation (get-text-property change-point 'slime-repl-presentation))
+ (unless (and this-presentation
+ (slime-same-presentation-p presentation this-presentation))
+ (return-from slime-presentation-start
+ (values (point) nil)))
+ (goto-char change-point)))
+ (values (point) t))))
+
+(defun* slime-presentation-end ()
+ "Find end of presentation at point. Return buffer index (after last
+ character of the presentation) and whether an end-tag was found."
+ (let* ((presentation (get-text-property (point) 'slime-repl-presentation))
+ (this-presentation presentation))
+ (unless presentation
+ (return-from slime-presentation-end
+ (values nil nil)))
+ (save-excursion
+ (while (and this-presentation
+ (slime-same-presentation-p presentation this-presentation)
+ (not (slime-presentation-stop-p this-presentation)))
+ (let ((change-point (next-single-property-change (point) 'slime-repl-presentation)))
+ (unless change-point
+ (return-from slime-presentation-end
+ (values (point-max) nil)))
+ (goto-char change-point)
+ (setq this-presentation (get-text-property (point) 'slime-repl-presentation))))
+ (if (and this-presentation
+ (slime-same-presentation-p presentation this-presentation))
+ (let ((after-end (next-single-property-change (point) 'slime-repl-presentation)))
+ (if (not after-end)
+ (values (point-max) t)
+ (values after-end t)))
+ (values (point) nil)))))
+
+(defun slime-presentation-around-point ()
+ "Return start index, end index, and whether the presentation is complete."
+ (multiple-value-bind (start good-start)
+ (slime-presentation-start)
+ (multiple-value-bind (end good-end)
+ (slime-presentation-end)
+ (values start end
+ (and good-start good-end
+ (slime-presentation-whole-p start end))))))
+
+(defun slime-after-change-function (start end old-len)
+ "Check all presentations within and adjacent to the change. When a
+ presentation has been altered, change it to plain text."
+ (unless undo-in-progress
+ (let ((real-start (max (point-min) (1- start)))
+ (real-end (min (point-max) (1+ end)))
+ (any-change nil))
+ ;; positions around the change
+ (save-excursion
+ (goto-char real-start)
+ (while (< (point) real-end)
+ (let ((presentation (get-text-property (point) 'slime-repl-presentation)))
+ (when presentation
+ (multiple-value-bind (from to whole)
+ (slime-presentation-around-point)
+ ;;(message "presentation %s whole-p %s" (buffer-substring from to) whole)
+ (unless whole
+ (setq any-change t)
+ (remove-text-properties from to
+ '(slime-repl-old-output t
+ slime-repl-inputed-output-face t
+ face t mouse-face t rear-nonsticky t
+ slime-repl-presentation t))))))
+ (let ((next-change
+ (next-single-property-change (point) 'slime-repl-presentation nil
+ real-end)))
+ (if next-change
+ (goto-char next-change)
+ (undo-boundary)
+ (return))))))))
(defun slime-copy-presentation-at-point (event)
(interactive "e")
@@ -2834,20 +2922,6 @@
(goto-char (point-max))
(do-insertion)))))))
-(put 'self-insert-command 'action-type 'inserts)
-(put 'self-insert-command-1 'action-type 'inserts)
-(put 'yank 'action-type 'inserts)
-(put 'kill-word 'action-type 'deletes-forward)
-(put 'delete-char 'action-type 'deletes-forward)
-(put 'kill-sexp 'action-type 'deletes-forward)
-(put 'backward-kill-sexp 'action-type 'deletes-backward)
-(put 'backward-delete-char 'action-type 'deletes-backward)
-(put 'delete-backward-char 'action-type 'deletes-backward)
-(put 'backward-kill-word 'action-type 'deletes-backward)
-(put 'backward-delete-char-untabify 'action-type 'deletes-backward)
-(put 'slime-repl-newline-and-indent 'action-type 'inserts)
-(put 'kill-ring-save 'action-type 'copies)
-
(defvar slime-presentation-map (make-sparse-keymap))
(define-key slime-presentation-map [mouse-2] 'slime-copy-presentation-at-point)
@@ -2891,25 +2965,31 @@
(defun slime-repl-insert-prompt (result &optional time)
"Goto to point max, insert RESULT and the prompt. Set
slime-output-end to start of the inserted text slime-input-start to
-end end."
+end end. If RESULT is not a string, it must be a list of
+result strings, each of which is marked-up as a presentation."
(slime-flush-output)
(goto-char (point-max))
(let ((start (point)))
(unless (bolp) (insert "\n"))
- (unless (string= "" result)
- (slime-propertize-region `(face slime-repl-result-face)
- (slime-propertize-region
- (and slime-repl-enable-presentations
- `(face slime-repl-result-face
- slime-repl-old-output ,(- slime-current-output-id)
- mouse-face slime-repl-output-mouseover-face
- keymap ,slime-presentation-map))
- (insert result)))
- (unless (bolp) (insert "\n"))
- (let ((inhibit-read-only t))
- (put-text-property (- (point) 2) (point)
- 'rear-nonsticky
- '(slime-repl-old-output face read-only))))
+ (flet ((insert-result (result id)
+ (if (and slime-repl-enable-presentations id)
+ (slime-insert-presentation result id)
+ (slime-propertize-region `(face slime-repl-result-face)
+ (insert result)))
+ (unless (bolp) (insert "\n"))
+ (let ((inhibit-read-only t))
+ (put-text-property (- (point) 2) (point)
+ 'rear-nonsticky
+ '(slime-repl-old-output slime-repl-presentation face read-only)))))
+ (etypecase result
+ (list
+ (loop
+ for res in result
+ for index from 0
+ do (insert-result res (cons (- slime-current-output-id) index))))
+ (string
+ (unless (string= result "")
+ (insert-result result nil)))))
(let ((prompt-start (point))
(prompt (format "%s> " (slime-lisp-package-prompt-string))))
(slime-propertize-region
@@ -2973,7 +3053,11 @@
(concat (substring str-no-props 0 pos)
;; Eval in the reader so that we play nice with quote.
;; -luke (19/May/2005)
- "#." (slime-prin1-to-string `(swank:get-repl-result ,id))
+ "#." (slime-prin1-to-string
+ (if (consp id)
+ `(cl:nth ,(cdr id)
+ (swank:get-repl-result ,(car id)))
+ `(swank:get-repl-result ,id)))
(reify-old-output (substring str-props end-pos)
(substring str-no-props end-pos)))))))
@@ -3027,8 +3111,11 @@
(set-marker slime-output-end position)))
(defun slime-mark-output-end ()
+ ;; Don't put slime-repl-output-face again; it would remove the
+ ;; special presentation face, for instance in the SBCL inspector.
(add-text-properties slime-output-start slime-output-end
- '(face slime-repl-output-face rear-nonsticky (face))))
+ '(;;face slime-repl-output-face
+ rear-nonsticky (face))))
(defun slime-repl-bol ()
"Go to the beginning of line or the prompt."
More information about the slime-cvs
mailing list