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