[slime-devel] Updated patch to improve SLIME presentations
Matthias Koeppe
mkoeppe+slime at mail.math.uni-magdeburg.de
Fri Jul 29 21:15:11 UTC 2005
Hi,
I am sending a new version of my patch of June 23.
The patch makes the presentations feature more robust and intuitive.
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.
The patch also makes it possible to access the individual values of
multiple-value results.
The patch also adds a "bridge"-less protocol for SLIME presentations.
Would someone like to handle this patch?
Cheers,
Matthias
--
Matthias Köppe -- http://www.math.uni-magdeburg.de/~mkoeppe
2005-07-29 Matthias Koeppe <mkoeppe at 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) , at 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 , at 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*)
More information about the slime-devel
mailing list