minad/completion.el

## completion.el
;;; -*- lexical-binding: t -*-

(require 'subr-x)

(defgroup minicomp nil
  "Minimal completion system."
  :group 'convenience
  :prefix "minicomp-")

(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.")

(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)

(defvar minicomp-map
  (let ((map (make-sparse-keymap)))
    (set-keymap-parent map minibuffer-local-map)
    (define-key map [remap beginning-of-buffer] #'minicomp-beginning)
    (define-key map [remap minibuffer-beginning-of-buffer] #'minicomp-beginning)
    (define-key map [remap end-of-buffer] #'minicomp-end)
    (define-key map [remap scroll-down-command] #'minicomp-back)
    (define-key map [remap scroll-up-command] #'minicomp-forward)
    (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 "\t" #'minicomp-insert)
    map)
  "Minibuffer keymap.")

(defvar-local minicomp--candidates-ov nil)
(defvar-local minicomp--count-ov nil)
(defvar-local minicomp--index 0)
(defvar-local minicomp--input nil)
(defvar-local minicomp--candidates nil)
(defvar-local minicomp--total nil)
(defvar-local minicomp--base 0)
(defvar-local minicomp--active nil)
(defvar-local minicomp--keep nil)

(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 (completion-metadata-get metadata 'affixation-function))
        (ann (completion-metadata-get metadata 'annotation-function)))
    (cond
     (aff (funcall aff candidates))
     (ann (mapcar (lambda (cand) (list cand (or (funcall ann cand) ""))) candidates))
     (t candidates))))

(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 minicomp-group-format
        (let ((new-title (caar (and group (funcall group (list cand))))))
          (unless (string= title new-title)
            (when new-title
              (setq displayed (concat displayed (format minicomp-group-format new-title) "\n")))
            (setq title new-title))))
      (setq cand (replace-regexp-in-string "\n+" "⤶" (replace-regexp-in-string "[\t ]+" " " (string-trim cand))))
      (setq cand (pcase (car ann-candidates)
                   (`(,_ ,y) (concat cand y))
                   (`(,_ ,x ,y) (concat x cand y))
                   (_ cand)))
      (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"))))
      (setq ann-candidates (cdr ann-candidates)
            index (1+ index)))
    (put-text-property 0 1 'cursor t displayed)
    (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."
  (let* ((start (minibuffer-prompt-end))
         (metadata (completion--field-metadata start))
         (input (buffer-substring-no-properties start (point-max))))
    (unless (string= minicomp--input input)
      (when (> minicomp--index 0)
        (setq minicomp--keep t))
      (let ((all (completion-all-completions
                  input
                  minibuffer-completion-table
                  minibuffer-completion-predicate
                  (- (point) start)
                  metadata))
            (old (and minicomp--keep
                      (>= minicomp--index 0)
                      (nth minicomp--index minicomp--candidates))))
        (setq minicomp--base
              (if-let (last (last all))
                  (prog1 (cdr last)
                    (setcdr last nil))
                0)
              minicomp--input input
              minicomp--total (length all)
              minicomp--candidates
              (if (> minicomp--total minicomp-sort-threshold)
                  all
                (funcall
                 (or (completion-metadata-get metadata 'display-sort-function)
                     #'minicomp--sort)
                 all)))
        (when-let* ((def (if (stringp minibuffer-default) minibuffer-default (car minibuffer-default)))
                    (rest (member def minicomp--candidates)))
          (setq minicomp--candidates (nconc (list (car rest)) (delete def minicomp--candidates))))
        (setq minicomp--index
              (if minicomp--candidates
                  (or (and old (seq-position minicomp--candidates old)) 0)
                -1))))
    (minicomp--display input metadata)))

(defun minicomp-beginning ()
  "Go to first candidate."
  (interactive)
  (setq minicomp--index (if (> minicomp--total 0) 0 -1)))

(defun minicomp-end ()
  "Go to last candidate."
  (interactive)
  (setq minicomp--index (- minicomp--total 1)))

(defun minicomp-back ()
  "Go back by one page."
  (interactive)
  (when (>= minicomp--index 0)
    (setq minicomp--index (max 0 (- minicomp--index minicomp-count)))))

(defun minicomp-forward ()
  "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
   ((or (not minibuffer--require-match)
        (eq minibuffer-completion-confirm 'confirm-after-completion)
        (test-completion (buffer-substring-no-properties
                          (minibuffer-prompt-end) (point-max))
                         minibuffer-completion-table
                         minibuffer-completion-predicate))
    (exit-minibuffer))
   ((eq minibuffer-completion-confirm 'confirm)
    (minibuffer-message "Confirm")
    (exit-minibuffer))
   (t (message "Match required"))))

(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--active t)
  (setq minicomp--candidates-ov (make-overlay (point-max) (point-max)))
  (setq minicomp--count-ov (make-overlay (point-min) (point-min)))
  (use-local-map minicomp-map)
  (add-hook 'post-command-hook #'minicomp--exhibit nil 'local))

(defun minicomp--advice (orig &rest args)
  "Advice for ORIG completion function, receiving ARGS."
  (minibuffer-with-setup-hook #'minicomp--setup (apply orig args)))

(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)))

(with-eval-after-load 'consult
  (add-hook 'consult--completion-candidate-hook
            (lambda ()
              (when minicomp--active
                (minicomp--candidate))))
  (add-hook 'consult--completion-refresh-hook
            (lambda ()
              (when minicomp--active
                (setq minicomp--input nil)
                (minicomp--exhibit)))))

(with-eval-after-load 'embark
  (add-hook 'embark-target-finders
            (lambda ()
                (when minicomp--active
                  (cons (completion-metadata-get (completion--field-metadata
                                                  (minibuffer-prompt-end))
                                                 'category)
	                (minicomp--candidate)))))
  (add-hook 'embark-candidate-collectors
            (lambda ()
              (when minicomp--active
                (cons (completion-metadata-get (completion--field-metadata
                                                (minibuffer-prompt-end))
                                               'category)
                      ;; full candidates?
                      minicomp--candidates)))))
	;;; -- lexical-binding: t --

	(require 'subr-x)

	(defgroup minicomp nil
	"Minimal completion system."
	:group 'convenience
	:prefix "minicomp-")

	(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.")

	(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)

	(defvar minicomp-map
	(let ((map (make-sparse-keymap)))
	(set-keymap-parent map minibuffer-local-map)
	(define-key map [remap beginning-of-buffer] #'minicomp-beginning)
	(define-key map [remap minibuffer-beginning-of-buffer] #'minicomp-beginning)
	(define-key map [remap end-of-buffer] #'minicomp-end)
	(define-key map [remap scroll-down-command] #'minicomp-back)
	(define-key map [remap scroll-up-command] #'minicomp-forward)
	(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 "\t" #'minicomp-insert)
	map)
	"Minibuffer keymap.")

	(defvar-local minicomp--candidates-ov nil)
	(defvar-local minicomp--count-ov nil)
	(defvar-local minicomp--index 0)
	(defvar-local minicomp--input nil)
	(defvar-local minicomp--candidates nil)
	(defvar-local minicomp--total nil)
	(defvar-local minicomp--base 0)
	(defvar-local minicomp--active nil)
	(defvar-local minicomp--keep nil)

	(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 (completion-metadata-get metadata 'affixation-function))
	(ann (completion-metadata-get metadata 'annotation-function)))
	(cond
	(aff (funcall aff candidates))
	(ann (mapcar (lambda (cand) (list cand (or (funcall ann cand) ""))) candidates))
	(t candidates))))

	(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 minicomp-group-format
	(let ((new-title (caar (and group (funcall group (list cand))))))
	(unless (string= title new-title)
	(when new-title
	(setq displayed (concat displayed (format minicomp-group-format new-title) "\n")))
	(setq title new-title))))
	(setq cand (replace-regexp-in-string "\n+" "⤶" (replace-regexp-in-string "[\t ]+" " " (string-trim cand))))
	(setq cand (pcase (car ann-candidates)
	(`(,_ ,y) (concat cand y))
	(`(,_ ,x ,y) (concat x cand y))
	(_ cand)))
	(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"))))
	(setq ann-candidates (cdr ann-candidates)
	index (1+ index)))
	(put-text-property 0 1 'cursor t displayed)
	(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."
	(let* ((start (minibuffer-prompt-end))
	(metadata (completion--field-metadata start))
	(input (buffer-substring-no-properties start (point-max))))
	(unless (string= minicomp--input input)
	(when (> minicomp--index 0)
	(setq minicomp--keep t))
	(let ((all (completion-all-completions
	input
	minibuffer-completion-table
	minibuffer-completion-predicate
	(- (point) start)
	metadata))
	(old (and minicomp--keep
	(>= minicomp--index 0)
	(nth minicomp--index minicomp--candidates))))
	(setq minicomp--base
	(if-let (last (last all))
	(prog1 (cdr last)
	(setcdr last nil))
	0)
	minicomp--input input
	minicomp--total (length all)
	minicomp--candidates
	(if (> minicomp--total minicomp-sort-threshold)
	all
	(funcall
	(or (completion-metadata-get metadata 'display-sort-function)
	#'minicomp--sort)
	all)))
	(when-let* ((def (if (stringp minibuffer-default) minibuffer-default (car minibuffer-default)))
	(rest (member def minicomp--candidates)))
	(setq minicomp--candidates (nconc (list (car rest)) (delete def minicomp--candidates))))
	(setq minicomp--index
	(if minicomp--candidates
	(or (and old (seq-position minicomp--candidates old)) 0)
	-1))))
	(minicomp--display input metadata)))

	(defun minicomp-beginning ()
	"Go to first candidate."
	(interactive)
	(setq minicomp--index (if (> minicomp--total 0) 0 -1)))

	(defun minicomp-end ()
	"Go to last candidate."
	(interactive)
	(setq minicomp--index (- minicomp--total 1)))

	(defun minicomp-back ()
	"Go back by one page."
	(interactive)
	(when (>= minicomp--index 0)
	(setq minicomp--index (max 0 (- minicomp--index minicomp-count)))))

	(defun minicomp-forward ()
	"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
	((or (not minibuffer--require-match)
	(eq minibuffer-completion-confirm 'confirm-after-completion)
	(test-completion (buffer-substring-no-properties
	(minibuffer-prompt-end) (point-max))
	minibuffer-completion-table
	minibuffer-completion-predicate))
	(exit-minibuffer))
	((eq minibuffer-completion-confirm 'confirm)
	(minibuffer-message "Confirm")
	(exit-minibuffer))
	(t (message "Match required"))))

	(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--active t)
	(setq minicomp--candidates-ov (make-overlay (point-max) (point-max)))
	(setq minicomp--count-ov (make-overlay (point-min) (point-min)))
	(use-local-map minicomp-map)
	(add-hook 'post-command-hook #'minicomp--exhibit nil 'local))

	(defun minicomp--advice (orig &rest args)
	"Advice for ORIG completion function, receiving ARGS."
	(minibuffer-with-setup-hook #'minicomp--setup (apply orig args)))

	(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)))

	(with-eval-after-load 'consult
	(add-hook 'consult--completion-candidate-hook
	(lambda ()
	(when minicomp--active
	(minicomp--candidate))))
	(add-hook 'consult--completion-refresh-hook
	(lambda ()
	(when minicomp--active
	(setq minicomp--input nil)
	(minicomp--exhibit)))))

	(with-eval-after-load 'embark
	(add-hook 'embark-target-finders
	(lambda ()
	(when minicomp--active
	(cons (completion-metadata-get (completion--field-metadata
	(minibuffer-prompt-end))
	'category)
	(minicomp--candidate)))))
	(add-hook 'embark-candidate-collectors
	(lambda ()
	(when minicomp--active
	(cons (completion-metadata-get (completion--field-metadata
	(minibuffer-prompt-end))
	'category)
	;; full candidates?
	minicomp--candidates)))))