emacs: Rename marker to highlighter (and make changes)

1 files changed, 128 insertions, 0 deletions

diff --git a/.config/emacs/site-lisp/highlighter.el b/.config/emacs/site-lisp/highlighter.el
new file mode 100644
index 0000000..ce67ac8
--- /dev/null
+++ b/.config/emacs/site-lisp/highlighter.el
@@ -0,0 +1,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)