branch: externals/vertico
commit 9355d050d45cd8071c784225ce1d53ed567c7617
Author: Daniel Mendler <m...@daniel-mendler.de>
Commit: Daniel Mendler <m...@daniel-mendler.de>
minicomp - initial commit
---
minicomp.el | 418 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1 file changed, 418 insertions(+)
diff --git a/minicomp.el b/minicomp.el
new file mode 100644
index 0000000..5d4d789
--- /dev/null
+++ b/minicomp.el
@@ -0,0 +1,418 @@
+;;; minicomp.el --- Minimal completion system -*- lexical-binding: t -*-
+
+;; Author: Daniel Mendler
+;; Maintainer: Daniel Mendler
+;; Created: 2021
+;; License: GPL-3.0-or-later
+;; Version: 0.1
+;; Package-Requires: ((emacs "27"))
+;; Homepage: https://github.com/minad/minicomp
+
+;; This file is not part of GNU Emacs.
+
+;; This program 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 program 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 program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Minimal completion system.
+
+;;; Code:
+
+(eval-when-compile
+ (require 'subr-x))
+
+(defgroup minicomp nil
+ "Minimal completion system."
+ :group 'convenience
+ :prefix "minicomp-")
+
+(defcustom minicomp-sort-threshold 10000
+ "Candidates will only be sorted if there are fewer than this threshold."
+ :type 'integer)
+
+(defcustom minicomp-group-format
+ (concat
+ #(" " 0 4 (face minicomp-group-separator))
+ #(" %s " 0 4 (face minicomp-group-title))
+ #(" " 0 1 (face minicomp-group-separator display (space :align-to right))))
+ "Format string used for the group title."
+ :type '(choice (const nil) string))
+
+(defcustom minicomp-count 10
+ "Maximal number of candidates to show."
+ :type 'integer)
+
+(defgroup minicomp-faces nil
+ "Faces used by Minicomp."
+ :group 'minicomp
+ :group 'faces)
+
+(defface minicomp-group-title
+ '((t :inherit shadow :slant italic))
+ "Face used for the title text of the candidate group headlines.")
+
+(defface minicomp-group-separator
+ '((t :inherit shadow :strike-through t))
+ "Face used for the separator lines of the candidate groups.")
+
+(defface minicomp-current
+ '((t :inherit highlight :extend t))
+ "Face used to highlight the currently selected candidate.")
+
+(defvar minicomp-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map minibuffer-local-map)
+ (define-key map [remap beginning-of-buffer] #'minicomp-beginning-of-buffer)
+ (define-key map [remap minibuffer-beginning-of-buffer]
#'minicomp-beginning-of-buffer)
+ (define-key map [remap end-of-buffer] #'minicomp-end-of-buffer)
+ (define-key map [remap scroll-down-command] #'minicomp-scroll-down)
+ (define-key map [remap scroll-up-command] #'minicomp-scroll-up)
+ (define-key map [remap next-line-or-history-element] #'minicomp-next)
+ (define-key map [remap previous-line-or-history-element]
#'minicomp-previous)
+ (define-key map [remap exit-minibuffer] #'minicomp-exit)
+ (define-key map [remap kill-ring-save] #'minicomp-save)
+ (define-key map "\t" #'minicomp-insert)
+ map)
+ "Minibuffer keymap.")
+
+(defvar-local minicomp--candidates-ov nil
+ "Overlay showing the candidates.")
+
+(defvar-local minicomp--count-ov nil
+ "Overlay showing the number of candidates.")
+
+(defvar-local minicomp--index 0
+ "Index of current candidate or negative for prompt selection.")
+
+(defvar-local minicomp--input nil
+ "Current input string or t.")
+
+(defvar-local minicomp--candidates nil
+ "List of candidates.")
+
+(defvar-local minicomp--base 0
+ "Size of the base string, which is concatenated with the candidate.")
+
+(defvar-local minicomp--total 0
+ "Length of the candidate list `minicomp--candidates'.")
+
+(defvar-local minicomp--keep nil
+ "Keep current candidate index `minicomp--index'.")
+
+(defun minicomp--sort (candidates)
+ "Sort CANDIDATES by history position, length and alphabetically."
+ ;; History disabled if `minibuffer-history-variable' eq `t'.
+ (let* ((list (and (not (eq minibuffer-history-variable t))
+ (symbol-value minibuffer-history-variable)))
+ (hist-len (length list))
+ (hist (make-hash-table :test #'equal
+ :size hist-len))
+ (hist-idx 0)
+ (cand candidates))
+ ;; Store the history position first in a hashtable in order to
+ ;; allow O(1) history lookup.
+ (dolist (elem list)
+ (unless (gethash elem hist)
+ (puthash elem hist-idx hist))
+ (setq hist-idx (1+ hist-idx)))
+ ;; Decorate each candidate with (hist-idx<<13) + length. This
+ ;; way we sort first by hist-idx and then by length. We assume
+ ;; that the candidates are not longer than 2**13 characters.
+ (while cand
+ (setcar cand (cons (car cand)
+ (+ (lsh (gethash (car cand) hist hist-len) 13)
+ (length (car cand)))))
+ (setq cand (cdr cand)))
+ (setq candidates
+ (sort candidates
+ (lambda (c1 c2)
+ (or (< (cdr c1) (cdr c2))
+ (and (= (cdr c1) (cdr c2))
+ (string< (car c1) (car c2))))))
+ cand candidates)
+ ;; Drop decoration from the candidates
+ (while cand
+ (setcar cand (caar cand))
+ (setq cand (cdr cand))))
+ candidates)
+
+(defun minicomp--annotate (metadata candidates)
+ "Annotate CANDIDATES with annotation function specified by METADATA."
+ (let ((aff (or (completion-metadata-get metadata 'affixation-function)
+ (plist-get completion-extra-properties :affixation-function)))
+ (ann (or (completion-metadata-get metadata 'annotation-function)
+ (plist-get completion-extra-properties
:annotation-function))))
+ (cond
+ (aff (funcall aff candidates))
+ (ann (mapcar (lambda (cand) (list cand (or (funcall ann cand) "")))
candidates))
+ (t candidates))))
+
+(defun minicomp--candidates (input metadata)
+ "Recompute candidates with INPUT string and METADATA."
+ (let* ((all (completion-all-completions
+ input
+ minibuffer-completion-table
+ minibuffer-completion-predicate
+ (- (point) (minibuffer-prompt-end))
+ metadata))
+ (base (if-let (last (last all))
+ (prog1 (cdr last)
+ (setcdr last nil))
+ 0))
+ (total (length all))
+ (candidates (if (> total minicomp-sort-threshold)
+ all
+ (funcall
+ (or (completion-metadata-get metadata
'display-sort-function)
+ #'minicomp--sort)
+ all))))
+ (when-let* ((def (cond
+ ((stringp (car-safe minibuffer-default)) (car
minibuffer-default))
+ ((stringp minibuffer-default) minibuffer-default)))
+ (rest (member def candidates)))
+ (setq candidates (nconc (list (car rest)) (delete def candidates))))
+ (when-let (group (completion-metadata-get metadata 'x-group-function))
+ (setq candidates (mapcan #'cdr (funcall group candidates))))
+ (list base total candidates)))
+
+(defun minicomp--recompute (input metadata)
+ "Preprocess candidates with INPUT string and METADATA."
+ (pcase (while-no-input (minicomp--candidates input metadata))
+ (`(,base ,total ,candidates)
+ (if-let* ((old (and candidates
+ minicomp--keep
+ (>= minicomp--index 0)
+ (nth minicomp--index minicomp--candidates)))
+ (idx (seq-position candidates old)))
+ (setq minicomp--index idx)
+ (setq minicomp--keep nil
+ minicomp--index (if candidates 0 -1)))
+ (setq minicomp--base base
+ minicomp--input input
+ minicomp--total total
+ minicomp--candidates candidates))))
+
+(defun minicomp--replace-prop (prop fun str)
+ "Replace STR parts with PROP using FUN."
+ (let ((len (length str)) (pos 0) (chunks))
+ (while (not (= pos len))
+ (let ((end (next-single-property-change pos prop str len)))
+ (push (if-let (val (get-text-property pos prop str))
+ (funcall fun val)
+ (substring str pos end))
+ chunks)
+ (setq pos end)))
+ (apply #'concat (nreverse chunks))))
+
+(defun minicomp--display (input metadata)
+ "Display current candidates with INPUT string and METADATA."
+ (let* ((index (min (max 0 (- minicomp--index (/ minicomp-count 2)))
+ (max 0 (- minicomp--total minicomp-count))))
+ (candidates (seq-take (nthcdr index minicomp--candidates)
minicomp-count))
+ (hl-candidates
+ (if (and (memq 'orderless completion-styles)
+ (fboundp 'orderless-highlight-matches))
+ (orderless-highlight-matches input candidates)
+ candidates))
+ (ann-candidates (minicomp--annotate metadata candidates))
+ (title nil)
+ (displayed (concat " " (and hl-candidates "\n")))
+ (group (completion-metadata-get metadata 'x-group-function)))
+ (dolist (cand hl-candidates)
+ (when-let (new-title (and minicomp-group-format group (caar (funcall
group (list cand)))))
+ (unless (equal title new-title)
+ (setq displayed (concat displayed (format minicomp-group-format
new-title) "\n")
+ title new-title)))
+ (setq cand (thread-last cand
+ (replace-regexp-in-string "[\t ]+" " ")
+ (replace-regexp-in-string "\n+" "⤶")
+ (string-trim)
+ (minicomp--replace-prop 'display (lambda (x) (if (stringp
x) x "")))
+ (minicomp--replace-prop 'invisible (lambda (_) ""))))
+ (pcase-let ((`(,prefix . ,suffix) (pcase (car ann-candidates)
+ (`(,_ ,y) (cons nil y))
+ (`(,x ,_ ,y) (cons x y))
+ (_ (cons nil "")))))
+ (setq cand (concat prefix cand
+ (if (text-property-not-all 0 (length suffix) 'face
nil suffix)
+ suffix
+ (propertize suffix 'face
'completions-annotations)))))
+ (when (= index minicomp--index)
+ (setq cand (concat cand))
+ (add-face-text-property 0 (length cand) 'minicomp-current 'append
cand))
+ (setq displayed (concat displayed cand
+ (when (cdr ann-candidates)
+ (if (= index minicomp--index)
+ (propertize "\n" 'face 'minicomp-current)
+ "\n")))
+ ann-candidates (cdr ann-candidates)
+ index (1+ index)))
+ (put-text-property 0 1 'cursor t displayed)
+ (if (< minicomp--index 0)
+ (add-text-properties (minibuffer-prompt-end) (point-max) '(face
minicomp-current))
+ (remove-text-properties (minibuffer-prompt-end) (point-max) '(face nil)))
+ (move-overlay minicomp--count-ov (point-min) (point-min))
+ (move-overlay minicomp--candidates-ov (point-max) (point-max))
+ (overlay-put minicomp--candidates-ov 'after-string displayed)
+ (overlay-put minicomp--count-ov 'before-string
+ (format "%-6s " (format "%s/%s"
+ (if (< minicomp--index 0) "*"
minicomp--index)
+ minicomp--total)))))
+
+(defun minicomp--exhibit ()
+ "Exhibit completion UI."
+ (setq minicomp--keep (or minicomp--keep (> minicomp--index 0)))
+ (let ((metadata (completion--field-metadata (minibuffer-prompt-end)))
+ (input (minibuffer-contents-no-properties)))
+ (unless (equal minicomp--input input)
+ (minicomp--recompute input metadata))
+ (minicomp--display input metadata)))
+
+(defun minicomp-beginning-of-buffer ()
+ "Go to first candidate."
+ (interactive)
+ (setq minicomp--index (if (> minicomp--total 0) 0 -1)))
+
+(defun minicomp-end-of-buffer ()
+ "Go to last candidate."
+ (interactive)
+ (setq minicomp--index (- minicomp--total 1)))
+
+(defun minicomp-scroll-down ()
+ "Go back by one page."
+ (interactive)
+ (when (>= minicomp--index 0)
+ (setq minicomp--index (max 0 (- minicomp--index minicomp-count)))))
+
+(defun minicomp-scroll-up ()
+ "Go forward by one page."
+ (interactive)
+ (when (>= minicomp--index 0)
+ (setq minicomp--index (min (- minicomp--total 1) (+ minicomp--index
minicomp-count)))))
+
+(defun minicomp-next ()
+ "Go to next candidate."
+ (interactive)
+ (setq minicomp--index (min (1+ minicomp--index) (- minicomp--total 1))))
+
+(defun minicomp-previous ()
+ "Go to previous candidate."
+ (interactive)
+ (setq minicomp--index (max -1 (- minicomp--index 1))))
+
+(defun minicomp-exit ()
+ "Exit minibuffer with current candidate."
+ (interactive)
+ (minicomp-insert)
+ (cond
+ ((let ((input (minibuffer-contents-no-properties)))
+ (or (not minibuffer--require-match)
+ (eq minibuffer-completion-confirm 'confirm-after-completion)
+ (equal "" input)
+ (test-completion input
+ minibuffer-completion-table
+ minibuffer-completion-predicate)))
+ (exit-minibuffer))
+ ((eq minibuffer-completion-confirm 'confirm)
+ (when (eq (read-char "Confirm") 13)
+ (exit-minibuffer)))
+ (t (message "Match required"))))
+
+(defun minicomp-save ()
+ "Save current candidate to kill ring."
+ (interactive)
+ (if (or (use-region-p) (not transient-mark-mode))
+ (call-interactively #'kill-ring-save)
+ (kill-new (minicomp--candidate))))
+
+(defun minicomp-insert ()
+ "Insert current candidate in minibuffer."
+ (interactive)
+ (let ((cand (minicomp--candidate)))
+ (delete-minibuffer-contents)
+ (insert cand)))
+
+(defun minicomp--candidate ()
+ "Return current candidate string."
+ (let ((content (minibuffer-contents-no-properties)))
+ (if (< minicomp--index 0)
+ content
+ (concat (substring content 0 minicomp--base)
+ (nth minicomp--index minicomp--candidates)))))
+
+(defun minicomp--setup ()
+ "Setup completion system."
+ (setq-local max-mini-window-height 1.0)
+ (when (boundp 'orderless-skip-highlighting)
+ (setq-local orderless-skip-highlighting t))
+ ;;(setq-local truncate-lines t)
+ (setq minicomp--input t
+ minicomp--candidates-ov (make-overlay (point-max) (point-max))
+ minicomp--count-ov (make-overlay (point-min) (point-min)))
+ (use-local-map minicomp-map)
+ (add-hook 'post-command-hook #'minicomp--exhibit -99 'local))
+
+(defun minicomp--advice (orig &rest args)
+ "Advice for ORIG completion function, receiving ARGS."
+ (minibuffer-with-setup-hook #'minicomp--setup (apply orig args)))
+
+;;;###autoload
+(define-minor-mode minicomp-mode
+ "Minimal completion system."
+ :global t
+ (if minicomp-mode
+ (progn
+ (advice-add #'completing-read-default :around #'minicomp--advice)
+ (advice-add #'completing-read-multiple :around #'minicomp--advice))
+ (advice-remove #'completing-read-default #'minicomp--advice)
+ (advice-remove #'completing-read-multiple #'minicomp--advice)))
+
+(defun minicomp--consult-candidate ()
+ "Current candidate."
+ (when minicomp--input
+ (minicomp--candidate)))
+
+(defun minicomp--consult-refresh ()
+ "Refresh ui."
+ (when minicomp--input
+ (setq minicomp--input t)
+ (minicomp--exhibit)))
+
+(defun minicomp--embark-target ()
+ "Return embark target."
+ (when minicomp--input
+ (cons (completion-metadata-get (completion--field-metadata
+ (minibuffer-prompt-end))
+ 'category)
+ (minicomp--candidate))))
+
+(defun minicomp--embark-candidates ()
+ "Return embark candidates."
+ (when minicomp--input
+ (cons (completion-metadata-get (completion--field-metadata
+ (minibuffer-prompt-end))
+ 'category)
+ ;; full candidates?
+ minicomp--candidates)))
+
+(with-eval-after-load 'consult
+ (add-hook 'consult--completion-candidate-hook #'minicomp--consult-candidate)
+ (add-hook 'consult--completion-refresh-hook #'minicomp--consult-refresh))
+
+(with-eval-after-load 'embark
+ (add-hook 'embark-target-finders #'minicomp--embark-target)
+ (add-hook 'embark-candidate-collectors #'minicomp--embark-candidates))
+
+(provide 'minicomp)
+;;; minicomp.el ends here
