dotfiles/emacs/.emacs.d/elpa/slime-20190724.1352/contrib/swank-presentations.lisp

;;; swank-presentations.lisp --- imitate LispM's presentations
;;
;; Authors: Alan Ruttenberg  <alanr-l@mumble.net>
;;          Luke Gorrie  <luke@synap.se>
;;          Helmut Eller  <heller@common-lisp.net>
;;          Matthias Koeppe  <mkoeppe@mail.math.uni-magdeburg.de>
;;
;; License: This code has been placed in the Public Domain.  All warranties
;;          are disclaimed.
;;

(in-package :swank)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (swank-require :swank-repl))

;;;; Recording and accessing results of computations

(defvar *record-repl-results* t
  "Non-nil means that REPL results are saved for later lookup.")

(defvar *object-to-presentation-id*
  (make-weak-key-hash-table :test 'eq)
  "Store the mapping of objects to numeric identifiers")

(defvar *presentation-id-to-object*
  (make-weak-value-hash-table :test 'eql)
  "Store the mapping of numeric identifiers to objects")

(defun clear-presentation-tables ()
  (clrhash *object-to-presentation-id*)
  (clrhash *presentation-id-to-object*))

(defvar *presentation-counter* 0 "identifier counter")

(defvar *nil-surrogate* (make-symbol "nil-surrogate"))

;; XXX thread safety? [2006-09-13] mb: not in the slightest (fwiw the
;; rest of slime isn't thread safe either), do we really care?
(defun save-presented-object (object)
  "Save OBJECT and return the assigned id.
If OBJECT was saved previously return the old id."
  (let ((object (if (null object) *nil-surrogate* object)))
    ;; We store *nil-surrogate* instead of nil, to distinguish it from
    ;; an object that was garbage collected.
    (or (gethash object *object-to-presentation-id*)
        (let ((id (incf *presentation-counter*)))
          (setf (gethash id *presentation-id-to-object*) object)
          (setf (gethash object *object-to-presentation-id*) id)
          id))))

(defslimefun lookup-presented-object (id)
  "Retrieve the object corresponding to ID.
The secondary value indicates the absence of an entry."
  (etypecase id
    (integer
     ;;
     (multiple-value-bind (object foundp)
         (gethash id *presentation-id-to-object*)
       (cond
         ((eql object *nil-surrogate*)
          ;; A stored nil object
          (values nil t))
         ((null object)
          ;; Object that was replaced by nil in the weak hash table
          ;; when the object was garbage collected.
          (values nil nil))
         (t
          (values object foundp)))))
    (cons
     (dcase id
       ((:frame-var thread-id frame index)
        (declare (ignore thread-id)) ; later
        (handler-case
            (frame-var-value frame index)
          (t (condition)
            (declare (ignore condition))
            (values nil nil))
          (:no-error (value)
            (values value t))))
       ((:inspected-part part-index)
        (inspector-nth-part part-index))))))

(defslimefun lookup-presented-object-or-lose (id)
  "Get the result of the previous REPL evaluation with ID."
  (multiple-value-bind (object foundp) (lookup-presented-object id)
    (cond (foundp object)
          (t (error "Attempt to access unrecorded object (id ~D)." id)))))

(defslimefun lookup-and-save-presented-object-or-lose (id)
  "Get the object associated with ID and save it in the presentation tables."
  (let ((obj (lookup-presented-object-or-lose id)))
    (save-presented-object obj)))

(defslimefun clear-repl-results ()
  "Forget the results of all previous REPL evaluations."
  (clear-presentation-tables)
  t)

(defun present-repl-results (values)
  ;; Override a function in swank.lisp, so that
  ;; presentations are associated with every REPL result.
  (flet ((send (value)
           (let ((id (and *record-repl-results*
                          (save-presented-object value))))
	     (send-to-emacs `(:presentation-start ,id :repl-result))
	     (send-to-emacs `(:write-string ,(prin1-to-string value)
					    :repl-result))
	     (send-to-emacs `(:presentation-end ,id :repl-result))
	     (send-to-emacs `(:write-string ,(string #\Newline)
					    :repl-result)))))
    (fresh-line)
    (finish-output)
    (if (null values)
        (send-to-emacs `(:write-string "; No value" :repl-result))
        (mapc #'send values))))


;;;; Presentation menu protocol
;;
;; To define a menu for a type of object, define a method
;; menu-choices-for-presentation on that object type.  This function
;; should return a list of two element lists where the first element is
;; the name of the menu action and the second is a function that will be
;; called if the menu is chosen. The function will be called with 3
;; arguments:
;;
;; choice: The string naming the action from above
;;
;; object: The object
;;
;; id: The presentation id of the object
;;
;; You might want append (when (next-method-p) (call-next-method)) to
;; pick up the Menu actions of superclasses.
;;

(defvar *presentation-active-menu* nil)

(defun menu-choices-for-presentation-id (id)
  (multiple-value-bind (ob presentp) (lookup-presented-object id)
    (cond ((not presentp) 'not-present)
	  (t
	   (let ((menu-and-actions (menu-choices-for-presentation ob)))
	     (setq *presentation-active-menu* (cons id menu-and-actions))
	     (mapcar 'car menu-and-actions))))))

(defun swank-ioify (thing)
  (cond ((keywordp thing) thing)
	((and (symbolp thing)(not (find #\: (symbol-name thing))))
	 (intern (symbol-name thing) 'swank-io-package))
	((consp thing) (cons (swank-ioify (car thing))
			     (swank-ioify (cdr thing))))
	(t thing)))

(defun execute-menu-choice-for-presentation-id (id count item)
  (let ((ob (lookup-presented-object id)))
    (assert (equal id (car *presentation-active-menu*)) ()
	    "Bug: Execute menu call for id ~a  but menu has id ~a"
	    id (car *presentation-active-menu*))
    (let ((action (second (nth (1- count) (cdr *presentation-active-menu*)))))
      (swank-ioify (funcall action item ob id)))))


(defgeneric menu-choices-for-presentation (object)
  (:method (ob) (declare (ignore ob)) nil)) ; default method

;; Pathname
(defmethod menu-choices-for-presentation ((ob pathname))
  (let* ((file-exists (ignore-errors (probe-file ob)))
	 (lisp-type (make-pathname :type "lisp"))
	 (source-file (and (not (member (pathname-type ob) '("lisp" "cl")
					:test 'equal))
			   (let ((source (merge-pathnames lisp-type ob)))
			     (and (ignore-errors (probe-file source))
				  source))))
	 (fasl-file (and file-exists
			 (equal (ignore-errors
				  (namestring
				   (truename
				    (compile-file-pathname
				     (merge-pathnames lisp-type ob)))))
				(namestring (truename ob))))))
    (remove nil
	    (list*
	     (and (and file-exists (not fasl-file))
		  (list "Edit this file"
			(lambda(choice object id)
			  (declare (ignore choice id))
			  (ed-in-emacs (namestring (truename object)))
			  nil)))
	     (and file-exists
		  (list "Dired containing directory"
			(lambda (choice object id)
			  (declare (ignore choice id))
			  (ed-in-emacs (namestring
					(truename
					 (merge-pathnames
					  (make-pathname :name "" :type "")
					  object))))
			  nil)))
	     (and fasl-file
		  (list "Load this fasl file"
			(lambda (choice object id)
			  (declare (ignore choice id object))
			  (load ob)
			  nil)))
	     (and fasl-file
		  (list "Delete this fasl file"
			(lambda (choice object id)
			  (declare (ignore choice id object))
			  (let ((nt (namestring (truename ob))))
			    (when (y-or-n-p-in-emacs "Delete ~a? " nt)
			      (delete-file nt)))
			  nil)))
	     (and source-file
		  (list "Edit lisp source file"
			(lambda (choice object id)
			  (declare (ignore choice id object))
			  (ed-in-emacs (namestring (truename source-file)))
			  nil)))
	     (and source-file
		  (list "Load lisp source file"
			(lambda(choice object id)
			  (declare (ignore choice id object))
			  (load source-file)
			  nil)))
	     (and (next-method-p) (call-next-method))))))

(defmethod menu-choices-for-presentation ((ob function))
  (list (list "Disassemble"
              (lambda (choice object id)
                (declare (ignore choice id))
                (disassemble object)))))

(defslimefun inspect-presentation (id reset-p)
  (let ((what (lookup-presented-object-or-lose id)))
    (when reset-p
      (reset-inspector))
    (inspect-object what)))

(defslimefun init-presentations ()
  ;; FIXME: import/use swank-repl to avoid package qualifier.
  (setq swank-repl:*send-repl-results-function* 'present-repl-results))

(provide :swank-presentations)