blob: ce67ac824a4cd1db8a55b7bd1ce92a0c6dbe2a18 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
|
;;; highlighter.el --- In-buffer highlighting commands -*- lexical-binding: t; -*-
(require 'seq)
(defgroup highlighter nil
"Customization group for `highlighter'."
:group 'convenience)
(defcustom highlighter-default-face 'match
"The default face used by `highlighter-mark'."
:type 'face
:package-version '(highlighter . "1.0.0")
:group 'highlighter)
(defun highlighter-mark (arg)
"Highlight text in the buffer.
Highlight the current line or region if it is active. Text is
highlighted using the face specified by `highlighter-default-face'.
With ARG, interactively pick a face to highlight with."
(declare (interactive-only t))
(interactive "P")
(let ((bounds (if (use-region-p)
(region-bounds)
`((,(pos-bol) . ,(pos-eol)))))
(face (when arg
(highlighter--read-face-name "Highlight with face" #'facep))))
(highlighter-mark-region bounds face))
(when (region-active-p)
(deactivate-mark)))
(defun highlighter-unmark (arg)
"Remove highlights in the buffer.
Remove highlights from the current line or region if it is active.
With ARG, interactively pick a face. Only highlights using the chosen
face will be removed."
(declare (interactive-only t))
(interactive "P")
(let ((bounds (if (use-region-p)
(region-bounds)
`((,(pos-bol) . ,(pos-eol)))))
(face (when arg
(highlighter--read-face-name
"Clear highlights using face"
#'highlighter--used-face-p))))
(highlighter-unmark-region bounds face))
(when (region-active-p)
(deactivate-mark)))
(defun highlighter-mark-region (bounds &optional face)
"Highlight text in the buffer within BOUNDS.
BOUNDS uses the same format as returned by `region-bounds'.
Text is highlighted using the face specified by `highlighter-default-face'.
If FACE is nil or omitted, `highlighter-default-face' is used."
(dolist (x bounds) (highlighter--mark-region (car x) (cdr x) face)))
(defun highlighter-unmark-region (bounds &optional face)
"Remove highlights in the buffer within BOUNDS.
BOUNDS uses the same format as returned by `region-bounds'.
If FACE is non-nil, only remove highlights using FACE."
(dolist (x bounds) (highlighter--unmark-region (car x) (cdr x) face)))
(defun highlighter--mark-region (beg end &optional face)
(let ((ov (make-overlay beg end nil :front-advance))
(face (or face highlighter-default-face 'match)))
(overlay-put ov 'priority 1)
(overlay-put ov 'face face)
(overlay-put ov 'evaporate t)
(overlay-put ov 'highlighter--mark-p t)
(overlay-put ov 'highlighter--face face)))
(defun highlighter--unmark-region (beg end &optional face)
(if face
(remove-overlays beg end 'highlighter--face face)
(remove-overlays beg end 'highlighter--mark-p t)))
(defun highlighter-unmark-buffer (arg)
"Remove highlights in the buffer.
With ARG, interactively pick a face. Only highlights using the chosen
face will be removed."
(declare (interactive-only t))
(interactive "P")
(let ((face (when arg
(highlighter--read-face-name
"Clear highlights using face"
#'highlighter--used-face-p))))
(highlighter--unmark-region (point-min) (point-max) face)))
(defun highlighter--read-face-name (prompt face-predicate)
(let (default defaults)
(let ((prompt (format "%s: " prompt))
(completion-extra-properties
`(:affixation-function
,(lambda (faces)
(mapcar
(lambda (face)
(list face
(concat (propertize read-face-name-sample-text
'face face)
"\t")
""))
faces))))
aliasfaces nonaliasfaces faces)
;; Build up the completion tables.
(mapatoms (lambda (s)
(when (apply face-predicate s nil)
(if (get s 'face-alias)
(push (symbol-name s) aliasfaces)
(push (symbol-name s) nonaliasfaces)))))
(let ((face (completing-read
prompt
(completion-table-in-turn nonaliasfaces aliasfaces)
nil t nil 'face-name-history defaults)))
(when (facep face) (if (stringp face)
(intern face)
face))))))
(defun highlighter--used-face-p (face)
(seq-filter (lambda (ov) (eq face (overlay-get ov 'highlighter--face)))
(overlays-in (point-min) (point-max))))
(provide 'highlighter)
|
