Klimi's new dotfiles with stow.
Nelze vybrat více než 25 témat Téma musí začínat písmenem nebo číslem, může obsahovat pomlčky („-“) a může být dlouhé až 35 znaků.

311 řádky
13 KiB

před 4 roky
  1. ;;; cider-overlays.el --- Managing CIDER overlays -*- lexical-binding: t; -*-
  2. ;; Copyright © 2015-2019 Bozhidar Batsov, Artur Malabarba and CIDER contributors
  3. ;; Author: Artur Malabarba <bruce.connor.am@gmail.com>
  4. ;; This program is free software; you can redistribute it and/or modify
  5. ;; it under the terms of the GNU General Public License as published by
  6. ;; the Free Software Foundation, either version 3 of the License, or
  7. ;; (at your option) any later version.
  8. ;; This program is distributed in the hope that it will be useful,
  9. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. ;; GNU General Public License for more details.
  12. ;; You should have received a copy of the GNU General Public License
  13. ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
  14. ;;; Commentary:
  15. ;; Use `cider--make-overlay' to place a generic overlay at point. Or use
  16. ;; `cider--make-result-overlay' to place an interactive eval result overlay at
  17. ;; the end of a specified line.
  18. ;;; Code:
  19. (require 'cider-common)
  20. (require 'subr-x)
  21. (require 'cider-compat)
  22. (require 'cl-lib)
  23. ;;; Customization
  24. (defface cider-result-overlay-face
  25. '((((class color) (background light))
  26. :background "grey90" :box (:line-width -1 :color "yellow"))
  27. (((class color) (background dark))
  28. :background "grey10" :box (:line-width -1 :color "black")))
  29. "Face used to display evaluation results at the end of line.
  30. If `cider-overlays-use-font-lock' is non-nil, this face is
  31. applied with lower priority than the syntax highlighting."
  32. :group 'cider
  33. :package-version '(cider "0.9.1"))
  34. (defcustom cider-result-use-clojure-font-lock t
  35. "If non-nil, interactive eval results are font-locked as Clojure code."
  36. :group 'cider
  37. :type 'boolean
  38. :package-version '(cider . "0.10.0"))
  39. (defcustom cider-overlays-use-font-lock t
  40. "If non-nil, results overlays are font-locked as Clojure code.
  41. If nil, apply `cider-result-overlay-face' to the entire overlay instead of
  42. font-locking it."
  43. :group 'cider
  44. :type 'boolean
  45. :package-version '(cider . "0.10.0"))
  46. (defcustom cider-use-overlays 'both
  47. "Whether to display evaluation results with overlays.
  48. If t, use overlays. If nil, display on the echo area. If both, display on
  49. both places.
  50. Only applies to evaluation commands. To configure the debugger overlays,
  51. see `cider-debug-use-overlays'."
  52. :type '(choice (const :tag "End of line" t)
  53. (const :tag "Bottom of screen" nil)
  54. (const :tag "Both" both))
  55. :group 'cider
  56. :package-version '(cider . "0.10.0"))
  57. (defcustom cider-eval-result-prefix "=> "
  58. "The prefix displayed in the minibuffer before a result value."
  59. :type 'string
  60. :group 'cider
  61. :package-version '(cider . "0.5.0"))
  62. (defcustom cider-eval-result-duration 'command
  63. "Duration, in seconds, of CIDER's eval-result overlays.
  64. If nil, overlays last indefinitely.
  65. If the symbol `command', they're erased after the next command.
  66. Also see `cider-use-overlays'."
  67. :type '(choice (integer :tag "Duration in seconds")
  68. (const :tag "Until next command" command)
  69. (const :tag "Last indefinitely" nil))
  70. :group 'cider
  71. :package-version '(cider . "0.10.0"))
  72. ;;; Overlay logic
  73. (defun cider--delete-overlay (ov &rest _)
  74. "Safely delete overlay OV.
  75. Never throws errors, and can be used in an overlay's modification-hooks."
  76. (ignore-errors (delete-overlay ov)))
  77. (defun cider--make-overlay (l r type &rest props)
  78. "Place an overlay between L and R and return it.
  79. TYPE is a symbol put on the overlay's category property. It is used to
  80. easily remove all overlays from a region with:
  81. (remove-overlays start end 'category TYPE)
  82. PROPS is a plist of properties and values to add to the overlay."
  83. (let ((o (make-overlay l (or r l) (current-buffer))))
  84. (overlay-put o 'category type)
  85. (overlay-put o 'cider-temporary t)
  86. (while props (overlay-put o (pop props) (pop props)))
  87. (push #'cider--delete-overlay (overlay-get o 'modification-hooks))
  88. o))
  89. (defun cider--remove-result-overlay ()
  90. "Remove result overlay from current buffer.
  91. This function also removes itself from `post-command-hook'."
  92. (remove-hook 'post-command-hook #'cider--remove-result-overlay 'local)
  93. (remove-overlays nil nil 'category 'result))
  94. (defun cider--remove-result-overlay-after-command ()
  95. "Add `cider--remove-result-overlay' locally to `post-command-hook'.
  96. This function also removes itself from `post-command-hook'."
  97. (remove-hook 'post-command-hook #'cider--remove-result-overlay-after-command 'local)
  98. (add-hook 'post-command-hook #'cider--remove-result-overlay nil 'local))
  99. (defface cider-fringe-good-face
  100. '((((class color) (background light)) :foreground "lightgreen")
  101. (((class color) (background dark)) :foreground "darkgreen"))
  102. "Face used on the fringe indicator for successful evaluation."
  103. :group 'cider)
  104. (defconst cider--fringe-overlay-good
  105. (propertize " " 'display '(left-fringe empty-line cider-fringe-good-face))
  106. "The before-string property that adds a green indicator on the fringe.")
  107. (defcustom cider-use-fringe-indicators t
  108. "Whether to display evaluation indicators on the left fringe."
  109. :safe #'booleanp
  110. :group 'cider
  111. :type 'boolean
  112. :package-version '(cider . "0.13.0"))
  113. (defun cider--make-fringe-overlay (&optional end)
  114. "Place an eval indicator at the fringe before a sexp.
  115. END is the position where the sexp ends, and defaults to point."
  116. (when cider-use-fringe-indicators
  117. (with-current-buffer (if (markerp end)
  118. (marker-buffer end)
  119. (current-buffer))
  120. (save-excursion
  121. (if end
  122. (goto-char end)
  123. (setq end (point)))
  124. (clojure-forward-logical-sexp -1)
  125. ;; Create the green-circle overlay.
  126. (cider--make-overlay (point) end 'cider-fringe-indicator
  127. 'before-string cider--fringe-overlay-good)))))
  128. (cl-defun cider--make-result-overlay (value &rest props &key where duration (type 'result)
  129. (format (concat " " cider-eval-result-prefix "%s "))
  130. (prepend-face 'cider-result-overlay-face)
  131. &allow-other-keys)
  132. "Place an overlay displaying VALUE at the end of line.
  133. VALUE is used as the overlay's after-string property, meaning it is
  134. displayed at the end of the overlay. The overlay itself is placed from
  135. beginning to end of current line.
  136. Return nil if the overlay was not placed or if it might not be visible, and
  137. return the overlay otherwise.
  138. Return the overlay if it was placed successfully, and nil if it failed.
  139. This function takes some optional keyword arguments:
  140. If WHERE is a number or a marker, apply the overlay over
  141. the entire line at that place (defaulting to `point'). If
  142. it is a cons cell, the car and cdr determine the start and
  143. end of the overlay.
  144. DURATION takes the same possible values as the
  145. `cider-eval-result-duration' variable.
  146. TYPE is passed to `cider--make-overlay' (defaults to `result').
  147. FORMAT is a string passed to `format'. It should have
  148. exactly one %s construct (for VALUE).
  149. All arguments beyond these (PROPS) are properties to be used on the
  150. overlay."
  151. (declare (indent 1))
  152. (while (keywordp (car props))
  153. (setq props (cdr (cdr props))))
  154. ;; If the marker points to a dead buffer, don't do anything.
  155. (let ((buffer (cond
  156. ((markerp where) (marker-buffer where))
  157. ((markerp (car-safe where)) (marker-buffer (car where)))
  158. (t (current-buffer)))))
  159. (with-current-buffer buffer
  160. (save-excursion
  161. (when (number-or-marker-p where)
  162. (goto-char where))
  163. ;; Make sure the overlay is actually at the end of the sexp.
  164. (skip-chars-backward "\r\n[:blank:]")
  165. (let* ((beg (if (consp where)
  166. (car where)
  167. (save-excursion
  168. (clojure-backward-logical-sexp 1)
  169. (point))))
  170. (end (if (consp where)
  171. (cdr where)
  172. (line-end-position)))
  173. (display-string (format format value))
  174. (o nil))
  175. (remove-overlays beg end 'category type)
  176. (funcall (if cider-overlays-use-font-lock
  177. #'font-lock-prepend-text-property
  178. #'put-text-property)
  179. 0 (length display-string)
  180. 'face prepend-face
  181. display-string)
  182. ;; If the display spans multiple lines or is very long, display it at
  183. ;; the beginning of the next line.
  184. (when (or (string-match "\n." display-string)
  185. (> (string-width display-string)
  186. (- (window-width) (current-column))))
  187. (setq display-string (concat " \n" display-string)))
  188. ;; Put the cursor property only once we're done manipulating the
  189. ;; string, since we want it to be at the first char.
  190. (put-text-property 0 1 'cursor 0 display-string)
  191. (when (> (string-width display-string) (* 3 (window-width)))
  192. (setq display-string
  193. (concat (substring display-string 0 (* 3 (window-width)))
  194. (substitute-command-keys
  195. "...\nResult truncated. Type `\\[cider-inspect-last-result]' to inspect it."))))
  196. ;; Create the result overlay.
  197. (setq o (apply #'cider--make-overlay
  198. beg end type
  199. 'after-string display-string
  200. props))
  201. (pcase duration
  202. ((pred numberp) (run-at-time duration nil #'cider--delete-overlay o))
  203. (`command
  204. ;; If inside a command-loop, tell `cider--remove-result-overlay'
  205. ;; to only remove after the *next* command.
  206. (if this-command
  207. (add-hook 'post-command-hook
  208. #'cider--remove-result-overlay-after-command
  209. nil 'local)
  210. (cider--remove-result-overlay-after-command))))
  211. (when-let* ((win (get-buffer-window buffer)))
  212. ;; Left edge is visible.
  213. (when (and (<= (window-start win) (point) (window-end win))
  214. ;; Right edge is visible. This is a little conservative
  215. ;; if the overlay contains line breaks.
  216. (or (< (+ (current-column) (string-width value))
  217. (window-width win))
  218. (not truncate-lines)))
  219. o)))))))
  220. ;;; Displaying eval result
  221. (defun cider--display-interactive-eval-result (value &optional point)
  222. "Display the result VALUE of an interactive eval operation.
  223. VALUE is syntax-highlighted and displayed in the echo area.
  224. If POINT and `cider-use-overlays' are non-nil, it is also displayed in an
  225. overlay at the end of the line containing POINT.
  226. Note that, while POINT can be a number, it's preferable to be a marker, as
  227. that will better handle some corner cases where the original buffer is not
  228. focused."
  229. (let* ((font-value (if cider-result-use-clojure-font-lock
  230. (cider-font-lock-as-clojure value)
  231. value))
  232. (used-overlay (when (and point cider-use-overlays)
  233. (cider--make-result-overlay font-value
  234. :where point
  235. :duration cider-eval-result-duration))))
  236. (message
  237. "%s"
  238. (propertize (format "%s%s" cider-eval-result-prefix font-value)
  239. ;; The following hides the message from the echo-area, but
  240. ;; displays it in the Messages buffer. We only hide the message
  241. ;; if the user wants to AND if the overlay succeeded.
  242. 'invisible (and used-overlay
  243. (not (eq cider-use-overlays 'both)))))))
  244. ;;; Fragile buttons
  245. (defface cider-fragile-button-face
  246. '((((type graphic))
  247. :box (:line-width 3 :style released-button)
  248. :inherit font-lock-warning-face)
  249. (t :inverse-video t))
  250. "Face for buttons that vanish when clicked."
  251. :package-version '(cider . "0.12.0")
  252. :group 'cider)
  253. (define-button-type 'cider-fragile
  254. 'action 'cider--overlay-destroy
  255. 'follow-link t
  256. 'face nil
  257. 'modification-hooks '(cider--overlay-destroy)
  258. 'help-echo "RET: delete this.")
  259. (defun cider--overlay-destroy (ov &rest r)
  260. "Delete overlay OV and its underlying text.
  261. If any other arguments are given (collected in R), only actually do anything
  262. if the first one is non-nil. This is so it works in `modification-hooks'."
  263. (unless (and r (not (car r)))
  264. (let ((inhibit-modification-hooks t)
  265. (beg (copy-marker (overlay-start ov)))
  266. (end (copy-marker (overlay-end ov))))
  267. (delete-overlay ov)
  268. (delete-region beg end)
  269. (goto-char beg)
  270. (when (= (char-after) (char-before) ?\n)
  271. (delete-char 1)))))
  272. (provide 'cider-overlays)
  273. ;;; cider-overlays.el ends here