emacs: Rename marker to highlighter (and make changes)

2 files changed, 128 insertions, 47 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)
diff --git a/.config/emacs/site-lisp/marker.el b/.config/emacs/site-lisp/marker.el
deleted file mode 100644
index f39cad4..0000000
--- a/.config/emacs/site-lisp/marker.el
+++ /dev/null
@@ -1,47 +0,0 @@
-(require 'hi-lock)
-(require 'seq)
-
-(defun marker-mark ()
-  (interactive)
-  (marker-mark-region (if (use-region-p)
-                          (region-bounds)
-                        `((,(pos-bol) . ,(pos-eol)))))
-  (when (region-active-p)
-    (deactivate-mark)))
-
-(defun marker-mark-region (bounds)
-  (dolist (x bounds) (marker--mark-region (car x) (cdr x))))
-
-(defun marker--mark-region (beg end)
-  (let ((ov (make-overlay beg end nil :front-advance)))
-    (overlay-put ov 'priority 1)
-    (overlay-put ov 'face 'hi-yellow)
-    (overlay-put ov 'evaporate t)
-    (overlay-put ov 'marker--mark-p t)))
-
-(defun marker-unmark ()
-  (interactive)
-  (if (use-region-p)
-      (marker-unmark-region (region-bounds))
-    (marker-clear))
-  (when (region-active-p)
-    (deactivate-mark)))
-
-(defun marker-unmark-region (bounds)
-  (dolist (x bounds) (marker--unmark-region (car x) (cdr x))))
-
-(defun marker--unmark-region (beg end)
-  (dolist (ov (seq-filter (lambda (ov) (overlay-get ov 'marker--mark-p))
-                          (overlays-in beg end)))
-    (cond ((< (overlay-start ov) beg)
-           (move-overlay ov (overlay-start ov) beg))
-          ((> (overlay-end ov) end)
-           (move-overlay ov end (overlay-end ov)))
-          (:else
-           (delete-overlay ov)))))
-
-(defun marker-clear ()
-  (interactive)
-  (remove-overlays nil nil 'marker--mark-p t))
-
-(provide 'marker)