Klimi's new dotfiles with stow.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

872 lines
39 KiB

(require 'slime)
(require 'bridge)
(require 'cl-lib)
(eval-when-compile
(require 'cl))
(define-slime-contrib slime-presentations
"Imitate LispM presentations."
(:authors "Alan Ruttenberg <alanr-l@mumble.net>"
"Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>")
(:license "GPL")
(:slime-dependencies slime-repl)
(:swank-dependencies swank-presentations)
(:on-load
(add-hook 'slime-repl-mode-hook
(lambda ()
;; Respect the syntax text properties of presentation.
(set (make-local-variable 'parse-sexp-lookup-properties) t)
(add-hook 'after-change-functions
'slime-after-change-function 'append t)))
(add-hook 'slime-event-hooks 'slime-dispatch-presentation-event)
(setq slime-write-string-function 'slime-presentation-write)
(add-hook 'slime-connected-hook 'slime-presentations-on-connected)
(add-hook 'slime-repl-return-hooks 'slime-presentation-on-return-pressed)
(add-hook 'slime-repl-current-input-hooks 'slime-presentation-current-input)
(add-hook 'slime-open-stream-hooks 'slime-presentation-on-stream-open)
(add-hook 'slime-repl-clear-buffer-hook 'slime-clear-presentations)
(add-hook 'slime-edit-definition-hooks 'slime-edit-presentation)
(setq sldb-insert-frame-variable-value-function
'slime-presentation-sldb-insert-frame-variable-value)
(slime-presentation-init-keymaps)
(slime-presentation-add-easy-menu)))
;; To get presentations in the inspector as well, add this to your
;; init file.
;;
;; (eval-after-load 'slime-presentations
;; '(setq slime-inspector-insert-ispec-function
;; 'slime-presentation-inspector-insert-ispec))
;;
(defface slime-repl-output-mouseover-face
'((t (:box (:line-width 1 :color "black" :style released-button)
:inherit slime-repl-inputed-output-face)))
"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 "light salmon"))
(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-repl-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-repl-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))))
(cl-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))))
(defvar slime-presentation-map (make-sparse-keymap))
(defun slime-ensure-presentation-overlay (start end presentation)
(unless (cl-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."
(cl-labels ((insert-it ()
(if rectangle
(slime-insert-indented string)
(insert string))))
(let ((start (point)))
(insert-it)
(slime-add-presentation-properties start (point) output-id t))))
(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)))
(cl-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 (point-min))))
(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)))
(cl-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))))
(cl-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 (or presentation (= point (point-min)))
(values presentation start end whole-p)
(slime-presentation-around-point (1- point) object)))))
(defun slime-presentation-around-or-before-point-or-error (point)
(multiple-value-bind (presentation start end whole-p)
(slime-presentation-around-or-before-point point)
(unless presentation
(error "No presentation at point"))
(values presentation start end whole-p)))
(cl-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'."
(cl-labels ((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@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-check-presentation (from to buffer presentation)
(unless (slime-eval `(cl:nth-value 1 (swank:lookup-presented-object
',(slime-presentation-id presentation))))
(with-current-buffer buffer
(slime-remove-presentation-properties from to presentation))))
(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)
(slime-check-presentation start end buffer presentation)
(if (with-current-buffer buffer
(eq major-mode 'slime-repl-mode))
(slime-copy-presentation-at-mouse-to-repl event)
(slime-inspect-presentation-at-mouse event))))
(defun slime-inspect-presentation (presentation start end buffer)
(let ((reset-p
(with-current-buffer buffer
(not (eq major-mode 'slime-inspector-mode)))))
(slime-eval-async `(swank:inspect-presentation ',(slime-presentation-id presentation) ,reset-p)
'slime-open-inspector)))
(defun slime-inspect-presentation-at-mouse (event)
(interactive "e")
(multiple-value-bind (presentation start end buffer)
(slime-presentation-around-click event)
(slime-inspect-presentation presentation start end buffer)))
(defun slime-inspect-presentation-at-point (point)
(interactive "d")
(multiple-value-bind (presentation start end)
(slime-presentation-around-or-before-point-or-error point)
(slime-inspect-presentation presentation start end (current-buffer))))
(defun slime-M-.-presentation (presentation start end buffer &optional where)
(let* ((id (slime-presentation-id presentation))
(presentation-string (format "Presentation %s" id))
(location (slime-eval `(swank:find-definition-for-thing
(swank:lookup-presented-object
',(slime-presentation-id presentation))))))
(unless (eq (car location) :error)
(slime-edit-definition-cont
(and location (list (make-slime-xref :dspec `(,presentation-string)
:location location)))
presentation-string
where))))
(defun slime-M-.-presentation-at-mouse (event)
(interactive "e")
(multiple-value-bind (presentation start end buffer)
(slime-presentation-around-click event)
(slime-M-.-presentation presentation start end buffer)))
(defun slime-M-.-presentation-at-point (point)
(interactive "d")
(multiple-value-bind (presentation start end)
(slime-presentation-around-or-before-point-or-error point)
(slime-M-.-presentation presentation start end (current-buffer))))
(defun slime-edit-presentation (name &optional where)
(if (or current-prefix-arg (not (equal (slime-symbol-at-point) name)))
nil ; NAME came from user explicitly, so decline.
(multiple-value-bind (presentation start end whole-p)
(slime-presentation-around-or-before-point (point))
(when presentation
(slime-M-.-presentation presentation start end (current-buffer) where)))))
(defun slime-copy-presentation-to-repl (presentation start end buffer)
(let ((text (with-current-buffer buffer
;; we use the buffer-substring rather than the
;; presentation text to capture any overlays
(buffer-substring start end)))
(id (slime-presentation-id presentation)))
(unless (integerp id)
(setq id (slime-eval `(swank:lookup-and-save-presented-object-or-lose ',id))))
(unless (eql major-mode 'slime-repl-mode)
(slime-switch-to-output-buffer))
(cl-flet ((do-insertion ()
(unless (looking-back "\\s-" (- (point) 1))
(insert " "))
(slime-insert-presentation text id)
(unless (or (eolp) (looking-at "\\s-"))
(insert " "))))
(if (>= (point) slime-repl-prompt-start-mark)
(do-insertion)
(save-excursion
(goto-char (point-max))
(do-insertion))))))
(defun slime-copy-presentation-at-mouse-to-repl (event)
(interactive "e")
(multiple-value-bind (presentation start end buffer)
(slime-presentation-around-click event)
(slime-copy-presentation-to-repl presentation start end buffer)))
(defun slime-copy-presentation-at-point-to-repl (point)
(interactive "d")
(multiple-value-bind (presentation start end)
(slime-presentation-around-or-before-point-or-error point)
(slime-copy-presentation-to-repl presentation start end (current-buffer))))
(defun slime-copy-presentation-at-mouse-to-point (event)
(interactive "e")
(multiple-value-bind (presentation start end buffer)
(slime-presentation-around-click event)
(let ((presentation-text
(with-current-buffer buffer
(buffer-substring start end))))
(when (not (string-match "\\s-"
(buffer-substring (1- (point)) (point))))
(insert " "))
(insert presentation-text)
(slime-after-change-function (point) (point))
(when (and (not (eolp)) (not (looking-at "\\s-")))
(insert " ")))))
(defun slime-copy-presentation-to-kill-ring (presentation start end buffer)
(let ((presentation-text
(with-current-buffer buffer
(buffer-substring start end))))
(kill-new presentation-text)
(message "Saved presentation \"%s\" to kill ring" presentation-text)))
(defun slime-copy-presentation-at-mouse-to-kill-ring (event)
(interactive "e")
(multiple-value-bind (presentation start end buffer)
(slime-presentation-around-click event)
(slime-copy-presentation-to-kill-ring presentation start end buffer)))
(defun slime-copy-presentation-at-point-to-kill-ring (point)
(interactive "d")
(multiple-value-bind (presentation start end)
(slime-presentation-around-or-before-point-or-error point)
(slime-copy-presentation-to-kill-ring presentation start end (current-buffer))))
(defun slime-describe-presentation (presentation)
(slime-eval-describe
`(swank::describe-to-string
(swank:lookup-presented-object ',(slime-presentation-id presentation)))))
(defun slime-describe-presentation-at-mouse (event)
(interactive "@e")
(multiple-value-bind (presentation) (slime-presentation-around-click event)
(slime-describe-presentation presentation)))
(defun slime-describe-presentation-at-point (point)
(interactive "d")
(multiple-value-bind (presentation)
(slime-presentation-around-or-before-point-or-error point)
(slime-describe-presentation presentation)))
(defun slime-pretty-print-presentation (presentation)
(slime-eval-describe
`(swank::swank-pprint
(cl:list
(swank:lookup-presented-object ',(slime-presentation-id presentation))))))
(defun slime-pretty-print-presentation-at-mouse (event)
(interactive "@e")
(multiple-value-bind (presentation) (slime-presentation-around-click event)
(slime-pretty-print-presentation presentation)))
(defun slime-pretty-print-presentation-at-point (point)
(interactive "d")
(multiple-value-bind (presentation)
(slime-presentation-around-or-before-point-or-error point)
(slime-pretty-print-presentation presentation)))
(defun slime-mark-presentation (point)
(interactive "d")
(multiple-value-bind (presentation start end)
(slime-presentation-around-or-before-point-or-error point)
(goto-char start)
(push-mark end nil t)))
(defun slime-previous-presentation (&optional arg)
"Move point to the beginning of the first presentation before point.
With ARG, do this that many times.
A negative argument means move forward instead."
(interactive "p")
(unless arg (setq arg 1))
(slime-next-presentation (- arg)))
(defun slime-next-presentation (&optional arg)
"Move point to the beginning of the next presentation after point.
With ARG, do this that many times.
A negative argument means move backward instead."
(interactive "p")
(unless arg (setq arg 1))
(cond
((plusp arg)
(dotimes (i arg)
;; First skip outside the current surrounding presentation (if any)
(multiple-value-bind (presentation start end)
(slime-presentation-around-point (point))
(when presentation
(goto-char end)))
(let ((p (next-single-property-change (point) 'slime-repl-presentation)))
(unless p
(error "No next presentation"))
(multiple-value-bind (presentation start end)
(slime-presentation-around-or-before-point-or-error p)
(goto-char start)))))
((minusp arg)
(dotimes (i (- arg))
;; First skip outside the current surrounding presentation (if any)
(multiple-value-bind (presentation start end)
(slime-presentation-around-point (point))
(when presentation
(goto-char start)))
(let ((p (previous-single-property-change (point) 'slime-repl-presentation)))
(unless p
(error "No previous presentation"))
(multiple-value-bind (presentation start end)
(slime-presentation-around-or-before-point-or-error p)
(goto-char start)))))))
(define-key slime-presentation-map [mouse-2] 'slime-copy-or-inspect-presentation-at-mouse)
(define-key slime-presentation-map [mouse-3] 'slime-presentation-menu)
(when (featurep 'xemacs)
(define-key slime-presentation-map [button2] 'slime-copy-or-inspect-presentation-at-mouse)
(define-key slime-presentation-map [button3] 'slime-presentation-menu))
;; protocol for handling up a menu.
;; 1. Send lisp message asking for menu choices for this object.
;; Get back list of strings.
;; 2. Let used choose
;; 3. Call back to execute menu choice, passing nth and string of choice
(defun slime-menu-choices-for-presentation (presentation buffer from to choice-to-lambda)
"Return a menu for `presentation' at `from'--`to' in `buffer', suitable for `x-popup-menu'."
(let* ((what (slime-presentation-id presentation))
(choices (with-current-buffer buffer
(slime-eval
`(swank::menu-choices-for-presentation-id ',what)))))
(cl-labels ((savel (f) ;; IMPORTANT - xemacs can't handle lambdas in x-popup-menu. So give them a name
(let ((sym (cl-gensym)))
(setf (gethash sym choice-to-lambda) f)
sym)))
(etypecase choices
(list
`(,(format "Presentation %s" (truncate-string-to-width
(slime-presentation-text presentation)
30 nil nil t))
(""
("Find Definition" . ,(savel 'slime-M-.-presentation-at-mouse))
("Inspect" . ,(savel 'slime-inspect-presentation-at-mouse))
("Describe" . ,(savel 'slime-describe-presentation-at-mouse))
("Pretty-print" . ,(savel 'slime-pretty-print-presentation-at-mouse))
("Copy to REPL" . ,(savel 'slime-copy-presentation-at-mouse-to-repl))
("Copy to kill ring" . ,(savel 'slime-copy-presentation-at-mouse-to-kill-ring))
,@(unless buffer-read-only
`(("Copy to point" . ,(savel 'slime-copy-presentation-at-mouse-to-point))))
,@(let ((nchoice 0))
(mapcar
(lambda (choice)
(incf nchoice)
(cons choice
(savel `(lambda ()
(interactive)
(slime-eval
'(swank::execute-menu-choice-for-presentation-id
',what ,nchoice ,(nth (1- nchoice) choices)))))))
choices)))))
(symbol ; not-present
(with-current-buffer buffer
(slime-remove-presentation-properties from to presentation))
(sit-for 0) ; allow redisplay
`("Object no longer recorded"
("sorry" . ,(if (featurep 'xemacs) nil '(nil)))))))))
(defun slime-presentation-menu (event)
(interactive "e")
(let* ((point (if (featurep 'xemacs) (event-point event)
(posn-point (event-end event))))
(window (if (featurep 'xemacs) (event-window event) (caadr event)))
(buffer (window-buffer window))
(choice-to-lambda (make-hash-table)))
(multiple-value-bind (presentation from to)
(with-current-buffer buffer
(slime-presentation-around-point point))
(unless presentation
(error "No presentation at event position"))
(let ((menu (slime-menu-choices-for-presentation
presentation buffer from to choice-to-lambda)))
(let ((choice (x-popup-menu event menu)))
(when choice
(call-interactively (gethash choice choice-to-lambda))))))))
(defun slime-presentation-expression (presentation)
"Return a string that contains a CL s-expression accessing
the presented object."
(let ((id (slime-presentation-id presentation)))
(etypecase id
(number
;; Make sure it works even if *read-base* is not 10.
(format "(swank:lookup-presented-object-or-lose %d.)" id))
(list
;; for frame variables and inspector parts
(format "(swank:lookup-presented-object-or-lose '%s)" id)))))
(defun slime-buffer-substring-with-reified-output (start end)
(let ((str-props (buffer-substring start end))
(str-no-props (buffer-substring-no-properties start end)))
(slime-reify-old-output str-props str-no-props)))
(defun slime-reify-old-output (str-props str-no-props)
(let ((pos (slime-property-position 'slime-repl-presentation str-props)))
(if (null pos)
str-no-props
(multiple-value-bind (presentation start-pos end-pos whole-p)
(slime-presentation-around-point pos str-props)
(if (not presentation)
str-no-props
(concat (substring str-no-props 0 pos)
;; Eval in the reader so that we play nice with quote.
;; -luke (19/May/2005)
"#." (slime-presentation-expression presentation)
(slime-reify-old-output (substring str-props end-pos)
(substring str-no-props end-pos))))))))
(defun slime-repl-grab-old-output (replace)
"Resend the old REPL output at point.
If replace it non-nil the current input is replaced with the old
output; otherwise the new input is appended."
(multiple-value-bind (presentation beg end)
(slime-presentation-around-or-before-point (point))
(slime-check-presentation beg end (current-buffer) presentation)
(let ((old-output (buffer-substring beg end))) ;;keep properties
;; Append the old input or replace the current input
(cond (replace (goto-char slime-repl-input-start-mark))
(t (goto-char (point-max))
(unless (eq (char-before) ?\ )
(insert " "))))
(delete-region (point) (point-max))
(let ((inhibit-read-only t))
(insert old-output)))))
;;; Presentation-related key bindings, non-context menu
(defvar slime-presentation-command-map nil
"Keymap for presentation-related commands. Bound to a prefix key.")
(defvar slime-presentation-bindings
'((?i slime-inspect-presentation-at-point)
(?d slime-describe-presentation-at-point)
(?w slime-copy-presentation-at-point-to-kill-ring)
(?r slime-copy-presentation-at-point-to-repl)
(?p slime-previous-presentation)
(?n slime-next-presentation)
(?\ slime-mark-presentation)))
(defun slime-presentation-init-keymaps ()
(slime-init-keymap 'slime-presentation-command-map nil t
slime-presentation-bindings)
(define-key slime-presentation-command-map "\M-o" 'slime-clear-presentations)
;; C-c C-v is the prefix for the presentation-command map.
(define-key slime-prefix-map "\C-v" slime-presentation-command-map))
(defun slime-presentation-around-or-before-point-p ()
(multiple-value-bind (presentation beg end)
(slime-presentation-around-or-before-point (point))
presentation))
(defvar slime-presentation-easy-menu
(let ((P '(slime-presentation-around-or-before-point-p)))
`("Presentations"
[ "Find Definition" slime-M-.-presentation-at-point ,P ]
[ "Inspect" slime-inspect-presentation-at-point ,P ]
[ "Describe" slime-describe-presentation-at-point ,P ]
[ "Pretty-print" slime-pretty-print-presentation-at-point ,P ]
[ "Copy to REPL" slime-copy-presentation-at-point-to-repl ,P ]
[ "Copy to kill ring" slime-copy-presentation-at-point-to-kill-ring ,P ]
[ "Mark" slime-mark-presentation ,P ]
"--"
[ "Previous presentation" slime-previous-presentation ]
[ "Next presentation" slime-next-presentation ]
"--"
[ "Clear all presentations" slime-clear-presentations ])))
(defun slime-presentation-add-easy-menu ()
(easy-menu-define menubar-slime-presentation slime-mode-map "Presentations" slime-presentation-easy-menu)
(easy-menu-define menubar-slime-presentation slime-repl-mode-map "Presentations" slime-presentation-easy-menu)
(easy-menu-define menubar-slime-presentation sldb-mode-map "Presentations" slime-presentation-easy-menu)
(easy-menu-define menubar-slime-presentation slime-inspector-mode-map "Presentations" slime-presentation-easy-menu)
(easy-menu-add slime-presentation-easy-menu 'slime-mode-map)
(easy-menu-add slime-presentation-easy-menu 'slime-repl-mode-map)
(easy-menu-add slime-presentation-easy-menu 'sldb-mode-map)
(easy-menu-add slime-presentation-easy-menu 'slime-inspector-mode-map))
;;; hook functions (hard to isolate stuff)
(defun slime-dispatch-presentation-event (event)
(slime-dcase event
((:presentation-start id &optional target)
(slime-mark-presentation-start id target)
t)
((:presentation-end id &optional target)
(slime-mark-presentation-end id target)
t)
(t nil)))
(defun slime-presentation-write-result (string)
(with-current-buffer (slime-output-buffer)
(let ((marker (slime-repl-output-target-marker :repl-result))
(saved-point (point-marker)))
(goto-char marker)
(slime-propertize-region `(face slime-repl-result-face
rear-nonsticky (face))
(insert string))
;; Move the input-start marker after the REPL result.
(set-marker marker (point))
(set-marker slime-output-end (point))
;; Restore point before insertion but only it if was farther
;; than `marker'. Omitting this breaks REPL test
;; `repl-type-ahead'.
(when (> saved-point (point))
(goto-char saved-point)))
(slime-repl-show-maximum-output)))
(defun slime-presentation-write (string &optional target)
(case target
((nil) ; Regular process output
(slime-repl-emit string))
(:repl-result
(slime-presentation-write-result string))
(t (slime-repl-emit-to-target string target))))
(defun slime-presentation-current-input (&optional until-point-p)
"Return the current input as string.
The input is the region from after the last prompt to the end of
buffer. Presentations of old results are expanded into code."
(slime-buffer-substring-with-reified-output (slime-repl-history-yank-start)
(if until-point-p
(point)
(point-max))))
(defun slime-presentation-on-return-pressed (end-of-input)
(when (and (car (slime-presentation-around-or-before-point (point)))
(< (point) slime-repl-input-start-mark))
(slime-repl-grab-old-output end-of-input)
(slime-repl-recenter-if-needed)
t))
(defun slime-presentation-bridge-insert (process output)
(slime-output-filter process (or output "")))
(defun slime-presentation-on-stream-open (stream)
(install-bridge)
(setq bridge-insert-function #'slime-presentation-bridge-insert)
(setq bridge-destination-insert nil)
(setq bridge-source-insert nil)
(setq bridge-handlers
(list* '("<" . slime-mark-presentation-start-handler)
'(">" . slime-mark-presentation-end-handler)
bridge-handlers)))
(defun slime-clear-presentations ()
"Forget all objects associated to SLIME presentations.
This allows the garbage collector to remove these objects
even on Common Lisp implementations without weak hash tables."
(interactive)
(slime-eval-async `(swank:clear-repl-results))
(unless (eql major-mode 'slime-repl-mode)
(slime-switch-to-output-buffer))
(slime-for-each-presentation-in-region 1 (1+ (buffer-size))
(lambda (presentation from to whole-p)
(slime-remove-presentation-properties from to
presentation))))
(defun slime-presentation-inspector-insert-ispec (ispec)
(if (stringp ispec)
(insert ispec)
(slime-dcase ispec
((:value string id)
(slime-propertize-region
(list 'slime-part-number id
'mouse-face 'highlight
'face 'slime-inspector-value-face)
(slime-insert-presentation string `(:inspected-part ,id) t)))
((:label string)
(insert (slime-inspector-fontify label string)))
((:action string id)
(slime-insert-propertized (list 'slime-action-number id
'mouse-face 'highlight
'face 'slime-inspector-action-face)
string)))))
(defun slime-presentation-sldb-insert-frame-variable-value (value frame index)
(slime-insert-presentation
(sldb-in-face local-value value)
`(:frame-var ,slime-current-thread ,(car frame) ,index) t))
(defun slime-presentations-on-connected ()
(slime-eval-async `(swank:init-presentations)))
(provide 'slime-presentations)