[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