[slime-cvs] CVS slime/contrib
heller
heller at common-lisp.net
Mon Aug 27 12:36:11 UTC 2007
Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv8431/contrib
Modified Files:
ChangeLog
Added Files:
slime-presentations.el
Log Message:
Move presentations to contrib. Part I.
* slime.el (slime-event-hooks, slime-dispatch-event): New hook.
(slime-write-string-function, slime-write-string): New hook.
(slime-repl-return-hooks, slime-repl-return): New hook.
(slime-repl-current-input-hooks, slime-repl-current-input): New hook.
(slime-open-stream-hooks, slime-open-stream-to-lisp): New hook.
(sldb-insert-locals, slime-inspector-insert-ispec): Don't use
presentations.
* contrib/slime-presentations.el: New file
--- /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/25 01:10:36 1.9
+++ /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/27 12:36:11 1.10
@@ -1,3 +1,9 @@
+2007-08-27 Helmut Eller <heller at common-lisp.net>
+
+ Move presentations to contrib. (ELisp part)
+
+ * slime-presentations.el: New file.
+
2007-08-24 Matthias Koeppe <mkoeppe at mail.math.uni-magdeburg.de>
Some fixes to the presentation-streams contrib.
--- /project/slime/cvsroot/slime/contrib/slime-presentations.el 2007/08/27 12:36:11 NONE
+++ /project/slime/cvsroot/slime/contrib/slime-presentations.el 2007/08/27 12:36:11 1.1
;;; swank-presentations.el --- imitat LispM' presentations
;;;
;;; Authors: Alan Ruttenberg <alanr-l at mumble.net>
;;; Matthias Koeppe <mkoeppe at mail.math.uni-magdeburg.de>
;;;
;;; License: GNU GPL (same license as Emacs)
;;;
;;; Installation
;;
;; Add this to your .emacs:
;;
;; (add-to-list 'load-path "<directory-of-this-file>")
;; (add-hook 'slime-load-hook (lambda () (require 'slime-presentations)))
;;
(defface slime-repl-output-mouseover-face
(if (featurep 'xemacs)
'((t (:bold t)))
(if (slime-face-inheritance-possible-p)
'((t
(:box
(:line-width 1 :color "black" :style released-button)
:inherit
slime-repl-inputed-output-face)))
'((t (:box (:line-width 1 :color "black"))))))
"Face for Lisp output in the SLIME REPL, when the mouse hovers over it"
:group 'slime-repl)
(defface slime-repl-inputed-output-face
'((((class color) (background light)) (:foreground "Red"))
(((class color) (background dark)) (:foreground "Red"))
(t (:slant italic)))
"Face for the result of an evaluation in the SLIME REPL."
:group 'slime-repl)
;; FIXME: This conditional is not right - just used because the code
;; here does not work in XEmacs.
(when (boundp 'text-property-default-nonsticky)
(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 (id &optional target)
"Mark the beginning of a presentation with the given ID.
TARGET can be nil (regular process output) or :repl-result."
(setf (gethash id slime-presentation-start-to-point)
;; We use markers because text can also be inserted before this presentation.
;; (Output arrives while we are writing presentations within REPL results.)
(copy-marker (slime-output-target-marker target) nil)))
(defun slime-mark-presentation-start-handler (process string)
(if (and string (string-match "<\\([-0-9]+\\)" string))
(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 &optional target)
"Mark the end of a presentation with the given ID.
TARGET can be nil (regular process output) or :repl-result."
(let ((start (gethash id slime-presentation-start-to-point)))
(remhash id slime-presentation-start-to-point)
(when start
(let* ((marker (slime-output-target-marker target))
(buffer (and marker (marker-buffer marker))))
(with-current-buffer buffer
(let ((end (marker-position marker)))
(slime-add-presentation-properties start end
id nil)))))))
(defun slime-mark-presentation-end-handler (process string)
(if (and string (string-match ">\\([-0-9]+\\)" string))
(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)
(defvar slime-presentation-syntax-table
(let ((table (copy-syntax-table lisp-mode-syntax-table)))
;; We give < and > parenthesis syntax, so that #< ... > is treated
;; as a balanced expression. This allows to use C-M-k, C-M-SPC,
;; etc. to deal with a whole presentation. (For Lisp mode, this
;; is not desirable, since we do not wish to get a mismatched
;; paren highlighted everytime we type < or >.)
(modify-syntax-entry ?< "(>" table)
(modify-syntax-entry ?> ")<" table)
table)
"Syntax table for presentations.")
(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."
(let* ((text (buffer-substring-no-properties start end))
(presentation (make-slime-presentation :text text :id id)))
(let ((inhibit-modification-hooks t))
(add-text-properties start end
`(modification-hooks (slime-after-change-function)
insert-in-front-hooks (slime-after-change-function)
insert-behind-hooks (slime-after-change-function)
syntax-table ,slime-presentation-syntax-table
rear-nonsticky t))
;; Use the presentation as the key of a text property
(case (- end start)
(0)
(1
(add-text-properties start end
`(slime-repl-presentation ,presentation
,presentation :start-and-end)))
(t
(add-text-properties start (1+ start)
`(slime-repl-presentation ,presentation
,presentation :start))
(when (> (- end start) 2)
(add-text-properties (1+ start) (1- end)
`(,presentation :interior)))
(add-text-properties (1- end) end
`(slime-repl-presentation ,presentation
,presentation :end))))
;; Also put an overlay for the face and the mouse-face. This enables
;; highlighting of nested presentations. However, overlays get lost
;; when we copy a presentation; their removal is also not undoable.
;; In these cases the mouse-face text properties need to take over ---
;; but they do not give nested highlighting.
(slime-ensure-presentation-overlay start end presentation))))
(defun slime-ensure-presentation-overlay (start end presentation)
(unless (find presentation (overlays-at start)
:key (lambda (overlay)
(overlay-get overlay 'slime-repl-presentation)))
(let ((overlay (make-overlay start end (current-buffer) t nil)))
(overlay-put overlay 'slime-repl-presentation presentation)
(overlay-put overlay 'mouse-face 'slime-repl-output-mouseover-face)
(overlay-put overlay 'help-echo
(if (eq major-mode 'slime-repl-mode)
"mouse-2: copy to input; mouse-3: menu"
"mouse-2: inspect; mouse-3: menu"))
(overlay-put overlay 'face 'slime-repl-inputed-output-face)
(overlay-put overlay 'keymap slime-presentation-map))))
(defun slime-remove-presentation-properties (from to presentation)
(let ((inhibit-read-only t))
(remove-text-properties from to
`(,presentation t syntax-table t rear-nonsticky t))
(when (eq (get-text-property from 'slime-repl-presentation) presentation)
(remove-text-properties from (1+ from) `(slime-repl-presentation t)))
(when (eq (get-text-property (1- to) 'slime-repl-presentation) presentation)
(remove-text-properties (1- to) to `(slime-repl-presentation t)))
(dolist (overlay (overlays-at from))
(when (eq (overlay-get overlay 'slime-repl-presentation) presentation)
(delete-overlay overlay)))))
(defun slime-insert-presentation (string output-id &optional rectangle)
"Insert STRING in current buffer and mark it as a presentation
corresponding to OUTPUT-ID. If RECTANGLE is true, indent multi-line
strings to line up below the current point."
(flet ((insert-it ()
(if rectangle
(slime-insert-possibly-as-rectangle string)
(insert string))))
(let ((start (point)))
(insert-it)
(slime-add-presentation-properties start (point) output-id t))))
(defvar slime-last-output-target-id 0
"The last integer we used as a TARGET id.")
(defvar slime-output-target-to-marker
(make-hash-table)
"Map from TARGET ids to Emacs markers that indicate where
output should be inserted.")
;; Note: We would like the entries to disappear when the buffers are
;; killed. We cannot just make the hash-table ":weakness 'value" --
;; there is no reference from the buffers to the markers in the
;; buffer, so entries would disappear even though the buffers are
;; alive. Best solution might be to make buffer-local variables that
;; keep the markers. --mkoeppe
(defun slime-output-target-marker (target)
"Return a marker that indicates where output for TARGET should
be inserted."
(case target
((nil)
(with-current-buffer (slime-output-buffer)
slime-output-end))
(:repl-result
(with-current-buffer (slime-output-buffer)
slime-repl-input-start-mark))
(t
(gethash target slime-output-target-to-marker))))
(defun slime-redirect-trace-output ()
"Redirect the trace output to a separate Emacs buffer."
(interactive)
(let ((buffer (get-buffer-create "*SLIME Trace Output*")))
(with-current-buffer buffer
(let ((marker (copy-marker (buffer-size)))
(target (incf slime-last-output-target-id)))
(puthash target marker slime-output-target-to-marker)
(slime-eval `(swank:redirect-trace-output ,target))))
(pop-to-buffer buffer)))
(defun slime-presentation-whole-p (presentation start end &optional object)
(let ((object (or object (current-buffer))))
(string= (etypecase object
(buffer (with-current-buffer object
(buffer-substring-no-properties start end)))
(string (substring-no-properties object start end)))
(slime-presentation-text presentation))))
(defun slime-presentations-around-point (point &optional object)
(let ((object (or object (current-buffer))))
(loop for (key value . rest) on (text-properties-at point object) by 'cddr
when (slime-presentation-p key)
collect key)))
(defun slime-presentation-start-p (tag)
(memq tag '(:start :start-and-end)))
(defun slime-presentation-stop-p (tag)
(memq tag '(:end :start-and-end)))
(defun* slime-presentation-start (point presentation
&optional (object (current-buffer)))
"Find start of `presentation' at `point' in `object'.
Return buffer index and whether a start-tag was found."
(let* ((this-presentation (get-text-property point presentation object)))
(while (not (slime-presentation-start-p this-presentation))
(let ((change-point (previous-single-property-change
point presentation object)))
(unless change-point
(return-from slime-presentation-start
(values (etypecase object
(buffer (with-current-buffer object 1))
(string 0))
nil)))
(setq this-presentation (get-text-property change-point
presentation object))
(unless this-presentation
(return-from slime-presentation-start
(values point nil)))
(setq point change-point)))
(values point t)))
(defun* slime-presentation-end (point presentation
&optional (object (current-buffer)))
"Find end of presentation at `point' in `object'. Return buffer
index (after last character of the presentation) and whether an
end-tag was found."
(let* ((this-presentation (get-text-property point presentation object)))
(while (not (slime-presentation-stop-p this-presentation))
(let ((change-point (next-single-property-change
point presentation object)))
(unless change-point
(return-from slime-presentation-end
(values (etypecase object
(buffer (with-current-buffer object (point-max)))
(string (length object)))
nil)))
(setq point change-point)
(setq this-presentation (get-text-property point
presentation object))))
(if this-presentation
(let ((after-end (next-single-property-change point
presentation object)))
(if (not after-end)
(values (etypecase object
(buffer (with-current-buffer object (point-max)))
(string (length object)))
t)
(values after-end t)))
(values point nil))))
(defun* slime-presentation-bounds (point presentation
&optional (object (current-buffer)))
"Return start index and end index of `presentation' around `point'
in `object', and whether the presentation is complete."
(multiple-value-bind (start good-start)
(slime-presentation-start point presentation object)
(multiple-value-bind (end good-end)
(slime-presentation-end point presentation object)
(values start end
(and good-start good-end
(slime-presentation-whole-p presentation
start end object))))))
(defun slime-presentation-around-point (point &optional object)
"Return presentation, start index, end index, and whether the
presentation is complete."
(let ((object (or object (current-buffer)))
(innermost-presentation nil)
(innermost-start 0)
(innermost-end most-positive-fixnum))
(dolist (presentation (slime-presentations-around-point point object))
(multiple-value-bind (start end whole-p)
(slime-presentation-bounds point presentation object)
(when whole-p
(when (< (- end start) (- innermost-end innermost-start))
(setq innermost-start start
innermost-end end
innermost-presentation presentation)))))
(values innermost-presentation
innermost-start innermost-end)))
(defun slime-presentation-around-or-before-point (point &optional object)
(let ((object (or object (current-buffer))))
(multiple-value-bind (presentation start end whole-p)
(slime-presentation-around-point point object)
(if presentation
(values presentation start end whole-p)
(slime-presentation-around-point (1- point) object)))))
(defun* slime-for-each-presentation-in-region (from to function &optional (object (current-buffer)))
"Call `function' with arguments `presentation', `start', `end',
`whole-p' for every presentation in the region `from'--`to' in the
string or buffer `object'."
(flet ((handle-presentation (presentation point)
(multiple-value-bind (start end whole-p)
(slime-presentation-bounds point presentation object)
(funcall function presentation start end whole-p))))
;; Handle presentations active at `from'.
(dolist (presentation (slime-presentations-around-point from object))
(handle-presentation presentation from))
;; Use the `slime-repl-presentation' property to search for new presentations.
(let ((point from))
(while (< point to)
(setq point (next-single-property-change point 'slime-repl-presentation object to))
(let* ((presentation (get-text-property point 'slime-repl-presentation object))
(status (get-text-property point presentation object)))
(when (slime-presentation-start-p status)
(handle-presentation presentation point)))))))
;; XEmacs compatibility hack, from message by Stephen J. Turnbull on
;; xemacs-beta at xemacs.org of 18 Mar 2002
(unless (boundp 'undo-in-progress)
(defvar undo-in-progress nil
"Placeholder defvar for XEmacs compatibility from SLIME.")
(defadvice undo-more (around slime activate)
(let ((undo-in-progress t)) ad-do-it)))
(defun slime-after-change-function (start end &rest ignore)
"Check all presentations within and adjacent to the change.
When a presentation has been altered, change it to plain text."
(let ((inhibit-modification-hooks t))
(let ((real-start (max 1 (1- start)))
(real-end (min (1+ (buffer-size)) (1+ end)))
(any-change nil))
;; positions around the change
(slime-for-each-presentation-in-region
real-start real-end
(lambda (presentation from to whole-p)
(cond
(whole-p
(slime-ensure-presentation-overlay from to presentation))
((not undo-in-progress)
(slime-remove-presentation-properties from to
presentation)
(setq any-change t)))))
(when any-change
(undo-boundary)))))
(defun slime-presentation-around-click (event)
"Return the presentation around the position of the mouse-click EVENT.
If there is no presentation, signal an error.
Also return the start position, end position, and buffer of the presentation."
(when (and (featurep 'xemacs) (not (button-press-event-p event)))
(error "Command must be bound to a button-press-event"))
(let ((point (if (featurep 'xemacs) (event-point event) (posn-point (event-end event))))
(window (if (featurep 'xemacs) (event-window event) (caadr event))))
(with-current-buffer (window-buffer window)
(multiple-value-bind (presentation start end)
(slime-presentation-around-point point)
(unless presentation
(error "No presentation at click"))
(values presentation start end (current-buffer))))))
(defun slime-copy-or-inspect-presentation-at-mouse (event)
(interactive "e") ; no "@" -- we don't want to select the clicked-at window
(multiple-value-bind (presentation start end buffer)
(slime-presentation-around-click event)
(if (with-current-buffer buffer
(eq major-mode 'slime-repl-mode))
(slime-copy-presentation-at-mouse event)
(slime-inspect-presentation-at-mouse event))))
[294 lines skipped]
More information about the slime-cvs
mailing list