Klimi's new dotfiles with stow.
Вы не можете выбрать более 25 тем Темы должны начинаться с буквы или цифры, могут содержать дефисы(-) и должны содержать не более 35 символов.

156 строки
5.6 KiB

4 лет назад
  1. (require 'slime)
  2. (require 'advice)
  3. (require 'slime-compiler-notes-tree) ; FIXME: actually only uses the tree bits, so that should be a library.
  4. (define-slime-contrib slime-references
  5. "Clickable references to documentation (SBCL only)."
  6. (:authors "Christophe Rhodes <csr21@cantab.net>"
  7. "Luke Gorrie <luke@bluetail.com>"
  8. "Tobias C. Rittweiler <tcr@freebits.de>")
  9. (:license "GPL")
  10. (:on-load
  11. (ad-enable-advice 'slime-note.message 'after 'slime-note.message+references)
  12. (ad-activate 'slime-note.message)
  13. (setq slime-tree-printer 'slime-tree-print-with-references)
  14. (add-hook 'sldb-extras-hooks 'sldb-maybe-insert-references))
  15. (:on-unload
  16. (ad-disable-advice 'slime-note.message 'after 'slime-note.message+references)
  17. (ad-deactivate 'slime-note.message)
  18. (setq slime-tree-printer 'slime-tree-default-printer)
  19. (remove-hook 'sldb-extras-hooks 'sldb-maybe-insert-references)))
  20. (defcustom slime-sbcl-manual-root "http://www.sbcl.org/manual/"
  21. "*The base URL of the SBCL manual, for documentation lookup."
  22. :type '(choice (string :tag "HTML Documentation")
  23. (const :tag "Info Documentation" :info))
  24. :group 'slime-mode)
  25. (defface sldb-reference-face
  26. (list (list t '(:underline t)))
  27. "Face for references."
  28. :group 'slime-debugger)
  29. ;;;;; SBCL-style references
  30. (defvar slime-references-local-keymap
  31. (let ((map (make-sparse-keymap "local keymap for slime references")))
  32. (define-key map [mouse-2] 'slime-lookup-reference-at-mouse)
  33. (define-key map [return] 'slime-lookup-reference-at-point)
  34. map))
  35. (defun slime-reference-properties (reference)
  36. "Return the properties for a reference.
  37. Only add clickability to properties we actually know how to lookup."
  38. (cl-destructuring-bind (where type what) reference
  39. (if (or (and (eq where :sbcl) (eq type :node))
  40. (and (eq where :ansi-cl)
  41. (memq type '(:function :special-operator :macro
  42. :type :system-class
  43. :section :glossary :issue))))
  44. `(slime-reference ,reference
  45. font-lock-face sldb-reference-face
  46. follow-link t
  47. mouse-face highlight
  48. help-echo "mouse-2: visit documentation."
  49. keymap ,slime-references-local-keymap))))
  50. (defun slime-insert-reference (reference)
  51. "Insert documentation reference from a condition.
  52. See SWANK-BACKEND:CONDITION-REFERENCES for the datatype."
  53. (cl-destructuring-bind (where type what) reference
  54. (insert "\n" (slime-format-reference-source where) ", ")
  55. (slime-insert-propertized (slime-reference-properties reference)
  56. (slime-format-reference-node what))
  57. (insert (format " [%s]" type))))
  58. (defun slime-insert-references (references)
  59. (when references
  60. (insert "\nSee also:")
  61. (slime-with-rigid-indentation 2
  62. (mapc #'slime-insert-reference references))))
  63. (defun slime-format-reference-source (where)
  64. (cl-case where
  65. (:amop "The Art of the Metaobject Protocol")
  66. (:ansi-cl "Common Lisp Hyperspec")
  67. (:sbcl "SBCL Manual")
  68. (t (format "%S" where))))
  69. (defun slime-format-reference-node (what)
  70. (if (listp what)
  71. (mapconcat #'prin1-to-string what ".")
  72. what))
  73. (defun slime-lookup-reference-at-point ()
  74. "Browse the documentation reference at point."
  75. (interactive)
  76. (let ((refs (get-text-property (point) 'slime-reference)))
  77. (if (null refs)
  78. (error "No references at point")
  79. (cl-destructuring-bind (where type what) refs
  80. (cl-case where
  81. (:ansi-cl
  82. (cl-case type
  83. (:section
  84. (browse-url (funcall common-lisp-hyperspec-section-fun what)))
  85. (:glossary
  86. (browse-url (funcall common-lisp-hyperspec-glossary-function what)))
  87. (:issue
  88. (browse-url (common-lisp-issuex what)))
  89. (:special-operator
  90. (browse-url (common-lisp-special-operator (downcase name))))
  91. (t
  92. (hyperspec-lookup what))))
  93. (t
  94. (case slime-sbcl-manual-root
  95. (:info
  96. (info (format "(sbcl)%s" what)))
  97. (t
  98. (browse-url
  99. (format "%s#%s" slime-sbcl-manual-root
  100. (subst-char-in-string ?\ ?\- what)))))))))))
  101. (defun slime-lookup-reference-at-mouse (event)
  102. "Invoke the action pointed at by the mouse."
  103. (interactive "e")
  104. (cl-destructuring-bind (mouse-1 (w pos . _) . _) event
  105. (save-excursion
  106. (goto-char pos)
  107. (slime-lookup-reference-at-point))))
  108. ;;;;; Hook into *SLIME COMPILATION*
  109. (defun slime-note.references (note)
  110. (plist-get note :references))
  111. ;;; FIXME: `compilation-mode' will swallow the `mouse-face'
  112. ;;; etc. properties.
  113. (defadvice slime-note.message (after slime-note.message+references)
  114. (setq ad-return-value
  115. (concat ad-return-value
  116. (with-temp-buffer
  117. (slime-insert-references
  118. (slime-note.references (ad-get-arg 0)))
  119. (buffer-string)))))
  120. ;;;;; Hook into slime-compiler-notes-tree
  121. (defun slime-tree-print-with-references (tree)
  122. ;; for SBCL-style references
  123. (slime-tree-default-printer tree)
  124. (let ((note (plist-get (slime-tree.plist tree) 'note)))
  125. (when note
  126. (let ((references (slime-note.references note)))
  127. (when references
  128. (terpri (current-buffer))
  129. (slime-insert-references references))))))
  130. ;;;;; Hook into SLDB
  131. (defun sldb-maybe-insert-references (extra)
  132. (slime-dcase extra
  133. ((:references references) (slime-insert-references references) t)
  134. (t nil)))
  135. (provide 'slime-references)