[slime-devel] Patch to improve presentations
Matthias Koeppe
mkoeppe+slime at mail.math.uni-magdeburg.de
Thu Jun 23 15:05:00 UTC 2005
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
--
Matthias Koeppe -- http://www.math.uni-magdeburg.de/~mkoeppe
More information about the slime-devel
mailing list