[slime-devel] Updated patch to improve SLIME presentations

-- Matthias Köppe -- http://www.math.uni-magdeburg.de/~mkoeppe 2005-07-29 Matthias Koeppe mkoeppe@mail.math.uni-magdeburg.de * slime.el (slime-dispatch-event): New events :presentation-start, :presentation-end for bridge-less presentation markup. * swank.lisp (dispatch-event, send-to-socket-io): Likewise. * swank.lisp (listener-eval): Store the whole values-list with add-repl-result. * slime.el (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.el (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.el (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.el (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. Index: slime.el =================================================================== RCS file: /project/slime/cvsroot/slime/slime.el,v retrieving revision 1.515 diff -u -p -r1.515 slime.el --- slime.el 29 Jul 2005 12:37:24 -0000 1.515 +++ slime.el 29 Jul 2005 20:02:26 -0000 @@ -868,15 +868,13 @@ This list of flushed between commands.") "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 @@ This list of flushed between commands.") (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) @@ -2285,6 +2284,10 @@ slime-repl-insert-prompt.") (destructure-case event ((:read-output output) (slime-output-string output)) + ((:presentation-start id) + (slime-mark-presentation-start id)) + ((:presentation-end id) + (slime-mark-presentation-end id)) ;; ((:emacs-rex form package thread continuation) (slime-set-state "|eval...") @@ -2566,40 +2569,85 @@ update window-point afterwards. If poin (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 () @@ -2615,8 +2663,8 @@ update window-point afterwards. If poin (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 @@ -2752,61 +2800,105 @@ joined together.")) (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") @@ -2830,20 +2922,6 @@ joined together.")) (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) @@ -2887,36 +2965,42 @@ joined together.")) (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 '(face slime-repl-prompt-face - read-only t - intangible t - slime-repl-prompt t - ;; emacs stuff - rear-nonsticky (slime-repl-prompt read-only face intangible) - ;; xemacs stuff - start-open t end-open t) + read-only t + intangible t + slime-repl-prompt t + ;; emacs stuff + rear-nonsticky (slime-repl-prompt read-only face intangible) + ;; xemacs stuff + start-open t end-open t) (insert prompt)) ;; FIXME: we could also set beginning-of-defun-function (setq defun-prompt-regexp (concat "^" prompt)) @@ -2969,7 +3053,11 @@ buffer. Presentations of old results are (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))))))) @@ -3023,8 +3111,11 @@ buffer. Presentations of old results are (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." Index: swank.lisp =================================================================== RCS file: /project/slime/cvsroot/slime/swank.lisp,v retrieving revision 1.313 diff -u -p -u -r1.313 swank.lisp --- swank.lisp 29 Jul 2005 12:38:21 -0000 1.313 +++ swank.lisp 29 Jul 2005 20:28:45 -0000 @@ -599,7 +599,8 @@ of the toplevel restart." (encode-message `(:eval ,(thread-id thread) ,@args) socket-io)) ((:emacs-return thread-id tag value) (send (find-thread thread-id) `(take-input ,tag ,value))) - (((:read-output :new-package :new-features :ed :%apply :indentation-update + (((:read-output :presentation-start :presentation-end + :new-package :new-features :ed :%apply :indentation-update :eval-no-wait) &rest _) (declare (ignore _)) @@ -719,6 +720,7 @@ of the toplevel restart." (declare (ignore thread)) (send `(:return ,@args))) (((:read-output :new-package :new-features :debug-condition + :presentation-start :presentation-end :indentation-update :ed :%apply :eval-no-wait) &rest _) (declare (ignore _)) @@ -1839,23 +1842,23 @@ Return its name and the string to use in (defparameter *repl-results* '() "Association list of old repl results.") (defslimefun listener-eval (string) (clear-user-input) (with-buffer-syntax () (let ((*slime-repl-suppress-output* :unset) (*slime-repl-advance-history* :unset)) (unless (or (and (eq values nil) (eq last-form nil)) (eq *slime-repl-advance-history* nil)) (setq *** ** ** * * (car values) /// // // / / values) (when *record-repl-results* - (add-repl-result *current-id* *))) + (add-repl-result *current-id* values))) (setq +++ ++ ++ + + last-form) (if (eq *slime-repl-suppress-output* t) "" (cond ((null values) "; No value") (t - (format nil "~{~S~^~%~}" values)))))))) + (mapcar #'prin1-to-string values)))))))) (defun add-repl-result (id val) (push (cons id val) *repl-results*)