Skip to content

Commit

Permalink
Add highlighting for target at point
Browse files Browse the repository at this point in the history
  • Loading branch information
@minad
minad committed Jul 25, 2021
1 parent 2206a65 commit 5905262
Showing 1 changed file with 126 additions and 78 deletions.
204 changes: 126 additions & 78 deletions embark.el
View file
Original file line number Diff line number Diff line change
Expand Up @@ -151,9 +151,11 @@ For any type not listed here, `embark-act' will use
embark-target-custom-variable-at-point
embark-target-identifier-at-point)
"List of functions to determine the target in current context.
Each function should take no arguments and return either a cons
of the form (type . target) where type is a symbol and target is
a string, or nil to indicate it found no target."
Each function should take no arguments and return either nil to
indicate that no target has been found, a cons (type . target)
where type is a symbol and target is a string, or a triple of the
form (type target . bounds), where bounds is the (beg . end)
bounds pair of the target at point for highlighting."
:type 'hook)

(defcustom embark-transformer-alist
Expand Down Expand Up @@ -208,6 +210,9 @@ is the key representation accepted by `define-key'."
"Face used to display key bindings.
Used by `embark-completing-read-prompter' and `embark-keymap-help'.")

(defface embark-target '((t :inherit highlight))
"Face used to highlight the target at point during `embark-act'.")

(defcustom embark-action-indicator
(let ((act (propertize "Act" 'face 'highlight)))
(cons act (concat act " on %2$s"
Expand Down Expand Up @@ -466,55 +471,63 @@ There are three kinds:

(defun embark-target-active-region ()
"Target the region if active."
;; TODO consider returning a string
(when (use-region-p) '(region . <region>)))

(autoload 'dired-get-filename "dired")

(defun embark-target-file-at-point ()
"Target file at point.
This function mostly relies on `ffap-file-at-point', with two exceptions:
1. In `dired-mode', it uses `dired-get-filename' instead.
2. In `emacs-lisp-mode', it only calls `ffap-file-at-point' if
point is in a string or comment, or if it is on symbol
preceded by `require' or `use-package'."
(when-let ((file (cond
((derived-mode-p 'dired-mode)
(dired-get-filename t 'no-error-if-not-filep))
((derived-mode-p 'emacs-lisp-mode)
(when (or (nth 3 (syntax-ppss)) ; in a string
(nth 4 (syntax-ppss)) ; or comment
(save-excursion
(unless (looking-at "\\_<")
(forward-symbol -1))
(forward-symbol -1)
(looking-at "use-package\\|require")))
(ffap-file-at-point)))
(t (ffap-file-at-point)))))
(cons 'file (abbreviate-file-name file))))
This function mostly relies on `ffap-file-at-point', with one exception:
In `dired-mode', it uses `dired-get-filename' instead."
(if-let (file (and (derived-mode-p 'dired-mode)
(dired-get-filename t 'no-error-if-not-filep)))
(save-excursion
(end-of-line)
`(file ,(abbreviate-file-name file)
,(save-excursion
(re-search-backward " " (line-beginning-position) 'noerror)
(1+ (point)))
. ,(point)))
(when-let (file (ffap-file-at-point))
`(file ,(abbreviate-file-name file)
. ,(bounds-of-thing-at-point 'filename)))))

(defun embark-target-bug-reference-at-point ()
"Target a bug reference at point."
(when-let ((url (seq-some (lambda (o) (overlay-get o 'bug-reference-url))
(overlays-at (point)))))
(cons 'url url)))
(when-let ((ov (seq-find (lambda (ov) (overlay-get ov 'bug-reference-url))
(overlays-at (point)))))
`(url ,(overlay-get ov 'bug-reference-url)
,(overlay-start ov) . ,(overlay-end ov))))

(defun embark-target-url-at-point ()
"Target the URL at point."
(when-let ((url (ffap-url-at-point)))
(cons 'url url)))
`(url ,url . ,(bounds-of-thing-at-point 'url))))

(declare-function widget-at "wid-edit")
(defun embark-target-custom-variable-at-point ()
"Target the variable corresponding to the customize widget at point."
(when (derived-mode-p 'Custom-mode)
(when-let ((symbol (get-text-property (point) 'custom-data)))
(cons 'variable (symbol-name symbol)))))
(save-excursion
(beginning-of-line)
;; TODO Please check, the old custom variable finder did not work for me.
(when-let* ((widget (widget-at (point)))
(var (and (eq (car widget) 'custom-visibility)
(plist-get (cdr widget) :parent)))
(sym (and (eq (car var) 'custom-variable)
(plist-get (cdr var) :value))))
`(variable
,(symbol-name sym)
,(point)
. ,(progn
(re-search-forward ":" (line-end-position) 'noerror)
(point)))))))

(defun embark-target-expression-at-point ()
"Target expression at point."
(pcase (bounds-of-thing-at-point 'sexp)
(`(,begin . ,end)
((and bounds `(,begin . ,end))
(let ((pt (point)))
(when (or (and (= pt begin)
(memq (syntax-class (syntax-after pt)) '(4 6 7)))
Expand All @@ -524,7 +537,7 @@ This function mostly relies on `ffap-file-at-point', with two exceptions:
(eq (syntax-class (syntax-after begin)) 6)
(eq (syntax-class (syntax-after pt)) 4)
(setq begin (1+ begin))))
(cons 'expression (buffer-substring begin end)))))))
`(expression ,(buffer-substring begin end) . ,bounds))))))

(defun embark-target-defun-at-point ()
"Target defun at point."
Expand All @@ -534,7 +547,7 @@ This function mostly relies on `ffap-file-at-point', with two exceptions:
(string-match "\\`(\\(?:\\w\\|\\s_\\)+" str)
(or (>= (point) (1- (cdr bounds)))
(<= (point) (+ (car bounds) (match-end 0)))))
(cons 'defun str)))))
`(defun ,str . ,bounds)))))

(defun embark-target-identifier-at-point ()
"Target identifier at point.
Expand All @@ -545,16 +558,18 @@ to symbols if they are interned Emacs Lisp symbols and found in a
buffer whose major mode does not inherit from `prog-mode'.
As a convenience, in Org Mode surrounding == or ~~ are removed."
(when-let ((name (thing-at-point 'symbol)))
(when (and (derived-mode-p 'org-mode)
(string-match-p "^\\([~=]\\).*\\1$" name))
(setq name (substring name 1 -1)))
(cons (if (or (derived-mode-p 'emacs-lisp-mode)
(and (intern-soft name)
(not (derived-mode-p 'prog-mode))))
'symbol
'identifier)
name)))
(when-let (bounds (bounds-of-thing-at-point 'symbol))
(let ((name (buffer-substring (car bounds) (cdr bounds))))
(when (and (derived-mode-p 'org-mode)
(string-match-p "^\\([~=]\\).*\\1$" name))
(setq name (substring name 1 -1)))
`(,(if (or (derived-mode-p 'emacs-lisp-mode)
(and (intern-soft name)
(not (derived-mode-p 'prog-mode))))
'symbol
'identifier)
,name
. ,bounds))))

(defun embark-target-top-minibuffer-completion ()
"Target the top completion candidate in the minibuffer.
Expand All @@ -579,14 +594,15 @@ Return the category metadatum as the type of the target."
"Target the collect candidate at point."
(when (derived-mode-p 'embark-collect-mode)
;; do not use button-label since it strips text properties
(when-let ((button (button-at (point)))
(label (buffer-substring
(button-start button)
(button-end button))))
(cons embark--type
(if (eq embark--type 'file)
(abbreviate-file-name (expand-file-name label))
label)))))
(when-let (button (button-at (point)))
(let* ((beg (button-start button))
(end (button-end button))
(label (buffer-substring beg end)))
`(,embark--type
,(if (eq embark--type 'file)
(abbreviate-file-name (expand-file-name label))
label)
,beg . ,end)))))

(defun embark-target-completion-at-point (&optional relative)
"Return the completion candidate at point in a completions buffer.
Expand All @@ -608,10 +624,11 @@ relative path."
(setq end (or (next-single-property-change end 'mouse-face)
(point-max)))
(let ((raw (buffer-substring beg end)))
(cons embark--type
(if (and (eq embark--type 'file) (not relative))
(abbreviate-file-name (expand-file-name raw))
raw)))))))
`(,embark--type
,(if (and (eq embark--type 'file) (not relative))
(abbreviate-file-name (expand-file-name raw))
raw)
,beg . ,end))))))

(defun embark--cycle-key ()
"Return the key to use for `embark-cycle'."
Expand Down Expand Up @@ -666,7 +683,11 @@ when the indicator is no longer needed."
indicator)
target type
(if (cdr targets)
(format "%S" (mapcar #'car (cdr targets)))
;; This is a weird feature of format/prin1-to-string.
;; A symbol list (function weird arbitrary symbols)
;; is printed as #'weird!
(let ((print-quoted nil))
(prin1-to-string (mapcar #'car (cdr targets))))
"")))
(if mini
(let ((indicator-overlay
Expand Down Expand Up @@ -879,6 +900,8 @@ minibuffer before executing the action."
(not (memq action embark-skip-edit-commands))
(memq action embark-allow-edit-commands)))
(inject
;; TODO consider using strings for regions,
;; remove special casing?
(if (not (stringp target)) ; for region actions
#'ignore
(lambda ()
Expand Down Expand Up @@ -982,9 +1005,10 @@ work on them."
"Retrieve current target.
An initial guess at the current target and its type is determined
by running the functions in `emark-target-finders'. Each function
should either return a pair of a type symbol and a target string,
or nil.
by running the functions in `embark-target-finders'. Each
function should either return nil, a pair of a type symbol and
target string or a triple of a type symbol, target string and
target bounds.
In the minibuffer only the first target finder returning non-nil
is taken into account. When finding targets at point in other
Expand All @@ -995,21 +1019,25 @@ variable `embark-transformer-alist'. If there is a transformer
for the type, it is called with the type and target, and must
return a `cons' of the transformed type and transformed target.
The return value of `embark--targets' is a list of pairs, where
each car is the transformed type and target and each cdr is the
original type and target."
The return value of `embark--targets' is a list. Each list
element has the form (target original-target . bounds), where
target and original-target are (type . string) pairs and bounds
is the optional bounds of the target at point for highlighting."
(let ((targets))
(run-hook-wrapped
'embark-target-finders
(lambda (fun)
(when-let (target (funcall fun))
(push (if-let (transformer (alist-get
(car target)
embark-transformer-alist))
(cons (funcall transformer (car target) (cdr target)) target)
(cons target target))
targets)
(minibufferp))))
(when-let (found (funcall fun))
(let* ((type (car found))
(target+bounds (cdr found))
(target (if (consp target+bounds) (car target+bounds) target+bounds))
(bounds (and (consp target+bounds) (cdr target+bounds)))
(orig (cons type target)))
(push (if-let (transformer (alist-get type embark-transformer-alist))
`(,(funcall transformer type target) ,orig . ,bounds)
`(,orig ,orig . ,bounds))
targets)
(minibufferp)))))
;; Delete duplicate targets. This is a rare scenario,
;; but could occur if we install multiple target finders
;; for the same type with different priorioties.
Expand Down Expand Up @@ -1059,22 +1087,40 @@ ARG is the prefix argument."
(while
(and
(catch 'embark--cycle
(pcase-let* ((`((,type . ,target) . (,_ . ,original)) (car targets))
(action (or (embark--prompt embark-action-indicator
(embark--action-keymap
type (cdr targets))
(mapcar #'car targets))
(pcase-let* ((`((,type . ,target)
(,_otype . ,otarget)
. ,bounds)
(car targets))
(action (or (embark--highlight-target
bounds
#'embark--prompt
embark-action-indicator
(embark--action-keymap
type (cdr targets))
(mapcar #'car targets))
(user-error "Canceled")))
(default-action (embark--default-action type)))
(embark--act action
(if (and (eq action default-action)
(eq action embark--command))
original
otarget
target)
(if embark-quit-after-action (not arg) arg)))
nil)
(setq targets (append (cdr targets) (list (car targets))))))))

(defun embark--highlight-target (bounds &rest fun)
"Highlight target at BOUNDS and call FUN."
(if bounds
(let ((ov (make-overlay (car bounds) (cdr bounds) nil)))
(overlay-put ov 'face 'embark-target)
(overlay-put ov 'window (selected-window))
(overlay-put ov 'priority 100) ;; override bug reference
(unwind-protect
(apply fun)
(delete-overlay ov)))
(apply fun)))

(defun embark-cycle ()
"Cycle to the next target at point."
(interactive)
Expand All @@ -1097,12 +1143,14 @@ keymap for the target's type.
See `embark-act' for the meaning of the prefix ARG."
(interactive "P")
(pcase-let* ((`((,type . ,target) . (,_ . ,original))
(pcase-let* ((`((,type . ,target)
(,_otype . ,otarget)
. ,_bounds)
(or (car (embark--targets)) (user-error "No target found")))
(default-action (embark--default-action type)))
(embark--act default-action
(if (eq default-action embark--command)
original
otarget
target)
(if embark-quit-after-action (not arg) arg))))

Expand Down

0 comments on commit 5905262

Please sign in to comment.