Hi,
thanks to all who have worked on the new presentations feature of SLIME. This is very nice work!
I am sending a patch that make the presentations feature a bit more robust and intuitive (IMHO). With the patch, parts of presentations can be copied reliably using all available Emacs facilities (not just kill-ring-save), and they are no longer "semi-readonly" (in the sense that keypresses are silently ignored). Whenever a user attempts to edit a presentation, it now simply turns into plain text (which is indicated by changing the face); this can be undone.
The patch removes the pre-command and post-command hooks and the classification of some modification commands into "action-type"s. In an after-change-function, I check whether only a part of a presentation has been pasted or whether a presentation has been edited.
Cheers, Matthias
Index: slime.el =================================================================== RCS file: /project/slime/cvsroot/slime/slime.el,v retrieving revision 1.509 diff -u -p -u -r1.509 slime.el --- slime.el 12 Jun 2005 21:05:29 -0000 1.509 +++ slime.el 23 Jun 2005 14:57:12 -0000 @@ -860,15 +860,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'." @@ -876,7 +874,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) @@ -2560,6 +2559,8 @@ 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)))
@@ -2584,16 +2585,56 @@ update window-point afterwards. If poin (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)))))))))) + (slime-add-presentation-properties start (symbol-value 'slime-output-end) + id nil)))))))) + +(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 + slime-repl-result-face + slime-repl-output-mouseover-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 () @@ -2746,61 +2787,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)) + (= (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") @@ -2824,20 +2909,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,19 +2958,15 @@ end end." (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))) + (if slime-repl-enable-presentations + (slime-insert-presentation result slime-current-output-id) + (slime-propertize-region `(face slime-repl-result-face) + (insert (substring result 1)))) (unless (bolp) (insert "\n")) (let ((inhibit-read-only t)) (put-text-property (- (point) 2) (point) 'rear-nonsticky - '(slime-repl-old-output face read-only)))) + '(slime-repl-old-output slime-repl-presentation face read-only)))) (let ((prompt-start (point)) (prompt (format "%s> " (slime-lisp-package-prompt-string)))) (slime-propertize-region