Add some-button to version control

diff --git a/.emacs.d/lisp/some-button.el b/.emacs.d/lisp/some-button.el
new file mode 100644 (file)
index 0000000..60d55da
--- /dev/null
+++ b/.emacs.d/lisp/some-button.el
@@ -0,0 +1,130 @@
+;;; some-button.el --- Push some button -*- lexical-binding: t -*-
+
+;; Copyright (C) 2021-2022 Eshel Yaron
+
+;; Author: Eshel Yaron <eshelshay.yaron@gmail.com>
+
+;; This file is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the
+;; Free Software Foundation, either version 3 of the License, or (at
+;; your option) any later version.
+
+;; This file is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this file.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Package-Version: 0.1.0
+;;; Package-Requires: ((emacs "29"))
+
+;;; Commentary:
+
+;;; Code:
+
+(defun some-button--completion-candidate (index button)
+  "Return a completion candidate for BUTTON prefixed by INDEX."
+  (cons (concat (propertize (format "%d " index)
+                            'invisible t)
+                (truncate-string-to-width
+                 (to-line (button-label button))
+                 64 nil ?\s t))
+        (button-start button)))
+
+(defun some-button--buttons (&optional buffer pom)
+  "Return an alist of buttons in BUFFER.
+Buttons following POM appear first in the resulting list."
+  (with-current-buffer (or buffer (current-buffer))
+    (let ((pos (or pom (point)))
+          (button (next-button (point-min)))
+          (index 1)
+          (buttons-before nil)
+          (buttons-after nil))
+      (while (and button (< (button-start button) pos))
+        (setq buttons-before
+              (cons (some-button--completion-candidate index button)
+                    buttons-before))
+        (setq index (1+ index))
+        (setq button (next-button (button-end button))))
+      (while button
+        (setq buttons-after
+              (cons (some-button--completion-candidate index button)
+                    buttons-after))
+        (setq index (1+ index))
+        (setq button (next-button (button-end button))))
+      (append (reverse buttons-after) (reverse buttons-before)))))
+
+(defun to-line (str)
+  "Inline STR."
+  (when str
+    (string-replace "\n" " " str)))
+
+(defun some-button--completing-read (prompt collection window buffer)
+  "Prompt for an button among COLLECTION with preview.
+PROMPT passed on to `completing-read'.  WINDOW is the window in
+which to show preview for locations in BUFFER."
+  (define-advice next-completion (:after (&rest _) after-advice)
+    (let* ((completion (with-minibuffer-completions-window
+                         (substring-no-properties
+                          (get-text-property (point)
+                                             'completion--string))))
+           (pos (cdr (assoc completion collection))))
+      (with-selected-window window
+        (unless (= (goto-char pos) (point))
+          (widen)
+          (goto-char pos))
+        (recenter)
+        (pulse-momentary-highlight-one-line))))
+  (unwind-protect
+      (let ((completions-sort nil)
+            ;  completion-extra-properties seems to get clobbered?
+            ;; (completion-extra-properties '(:annotate-function
+            ;;                                esy/annotate-button))
+            (completion-annotate-function
+             (some-button--annotate-function collection buffer)))
+        (completing-read prompt collection nil t nil nil (caar collection)))
+    (advice-remove #'next-completion
+                   'next-completion@after-advice)))
+
+(defun some-button--annotate-function (collection buffer)
+  "Annotate candidate amond COLLECTION in BUFFER."
+  (lambda (key)
+    (with-current-buffer buffer
+      (let* ((button (button-at
+                      (cdr
+                       (assoc key collection))))
+             (type (or (button-type button)
+                       (button-get button 'action)))
+             (url (button-get button 'shr-url))
+             (turl (and url
+                        (truncate-string-to-width
+                         (to-line url) 80 nil ?\s t))))
+        (to-line
+         (if type
+             (if turl
+                 (format "\t%S %64s" type turl)
+               (format "\t%S" type))
+           (when turl
+             (format "\t%64s" turl))))))))
+
+;;;###autoload
+(defun some-button (&optional arg)
+  "Push a button in the current buffer with completion and preview."
+  (interactive "P")
+  (if-let ((buf (current-buffer))
+           (win (selected-window))
+           (table (some-button--buttons)))
+      (let* ((choice (save-excursion
+                       (some-button--completing-read
+                        "Button: " table win buf)))
+             (pos (cdr (assoc choice table))))
+        (goto-char pos)
+        (when (not arg)
+          (or (ignore-errors (push-button))
+              (shr-browse-url))))
+    (user-error "No buttons in current buffer")))
+
+(provide 'some-button)
+;;; some-button.el ends here