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