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