252 lines
9.9 KiB
EmacsLisp
252 lines
9.9 KiB
EmacsLisp
;;; company-flx.el --- flx based fuzzy matching for company -*- lexical-binding: t -*-
|
|
|
|
;; Copyright (C) 2015, 2018 PythonNut
|
|
|
|
;; Author: PythonNut <pythonnut@pythonnut.com>
|
|
;; Keywords: convenience, company, fuzzy, flx
|
|
;; Package-Version: 20180103.518
|
|
;; Version: 20151016
|
|
;; URL: https://github.com/PythonNut/company-flx
|
|
;; Package-Requires: ((emacs "24") (company "0.8.12") (flx "0.5"))
|
|
|
|
;;; License:
|
|
|
|
;; 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:
|
|
|
|
;; This package adds fuzzy matching to company, powered by the sophisticated sorting heuristics in flx.
|
|
|
|
;; Usage
|
|
;; =====
|
|
|
|
;; To install, either clone this package directly, or execute M-x package-install RET company-flx RET.
|
|
|
|
;; After the package is installed, you can enable `company-flx` by adding the following to your init file:
|
|
|
|
;; (with-eval-after-load 'company
|
|
;; (company-flx-mode +1))
|
|
|
|
;;; Code:
|
|
|
|
(require 'company)
|
|
(require 'cl-lib)
|
|
|
|
(eval-when-compile
|
|
(with-demoted-errors "Load error: %s"
|
|
(require 'flx)))
|
|
|
|
(defgroup company-flx nil
|
|
"Sort company candidates by flx score"
|
|
:group 'convenience
|
|
:prefix "company-flx-")
|
|
|
|
(defcustom company-flx-limit 500
|
|
"The maximum number of company candidates to flx sort"
|
|
:type 'number
|
|
:group 'company-flx)
|
|
|
|
(defvar company-flx-cache nil
|
|
"Stores company-mode's flx-cache")
|
|
|
|
(defun company-flx-commonality (strs)
|
|
"Return the largest string that fuzzy matches all STRS"
|
|
(cl-letf* ((commonality-cache (make-hash-table :test 'equal :size 200))
|
|
((symbol-function
|
|
#'fuzzy-commonality)
|
|
(lambda (strs)
|
|
(let ((hash-value (gethash strs commonality-cache nil)))
|
|
(if hash-value
|
|
(if (eq hash-value 'nothing)
|
|
nil
|
|
hash-value)
|
|
|
|
(setq strs (mapcar #'string-to-list strs))
|
|
(let ((res) (tried) (idx))
|
|
(dolist (char (car strs))
|
|
(unless (memq char tried)
|
|
(catch 'notfound
|
|
(setq idx (mapcar (lambda (str)
|
|
(or
|
|
(cl-position char str)
|
|
(throw 'notfound nil)))
|
|
strs))
|
|
(push (cons char
|
|
(fuzzy-commonality
|
|
(cl-mapcar (lambda (str idx)
|
|
(cl-subseq str (1+ idx)))
|
|
strs idx)))
|
|
res)
|
|
(push char tried))))
|
|
(setq res (if res
|
|
(cl-reduce
|
|
(lambda (a b)
|
|
(if (> (length a) (length b)) a b))
|
|
res)
|
|
nil))
|
|
(puthash strs
|
|
(if res res 'nothing)
|
|
commonality-cache)
|
|
res))))))
|
|
(concat (fuzzy-commonality strs))))
|
|
|
|
(defun company-flx-find-holes (merged str)
|
|
"Find positions in MERGED, where insertion by the user is likely, wrt. STR"
|
|
(require 'flx)
|
|
(let ((holes) (matches (cdr (flx-score str merged company-flx-cache))))
|
|
(dolist (i (number-sequence 0 (- (length matches) 2)))
|
|
(when (>
|
|
(elt matches (1+ i))
|
|
(1+ (elt matches i)))
|
|
(push (1+ i) holes)))
|
|
(unless (<= (length str) (car (last matches)))
|
|
(push (length merged) holes))
|
|
holes))
|
|
|
|
(defun company-flx-merge (strs)
|
|
"Merge a collection of strings, including their collective holes"
|
|
(let ((common (company-flx-commonality strs))
|
|
(holes))
|
|
(setq holes (make-vector (1+ (length common)) 0))
|
|
(dolist (str strs)
|
|
(dolist (hole (company-flx-find-holes common str))
|
|
(cl-incf (elt holes hole))))
|
|
|
|
(cons common (append holes nil))))
|
|
|
|
(defun company-flx-completion (string table predicate point
|
|
&optional all-p)
|
|
"Helper function implementing a fuzzy completion-style"
|
|
(let* ((beforepoint (substring string 0 point))
|
|
(afterpoint (substring string point))
|
|
(boundaries (completion-boundaries beforepoint table predicate afterpoint))
|
|
(prefix (substring beforepoint 0 (car boundaries)))
|
|
(infix (concat
|
|
(substring beforepoint (car boundaries))
|
|
(substring afterpoint 0 (cdr boundaries))))
|
|
(suffix (substring afterpoint (cdr boundaries)))
|
|
;; |- string -|
|
|
;; point^
|
|
;; |- boundaries -|
|
|
;; |- prefix -|- infix -|- suffix -|
|
|
;;
|
|
;; Infix is the part supposed to be completed by table, AFAIKT.
|
|
(regexp (concat "\\`"
|
|
(mapconcat
|
|
(lambda (x)
|
|
(setq x (string x))
|
|
(concat "[^" x "]*" (regexp-quote x)))
|
|
infix
|
|
"")))
|
|
(completion-regexp-list (cons regexp completion-regexp-list))
|
|
(candidates (or (all-completions prefix table predicate)
|
|
(all-completions infix table predicate))))
|
|
|
|
(if all-p
|
|
;; Implement completion-all-completions interface
|
|
(when candidates
|
|
;; Not doing this may result in an error.
|
|
(setcdr (last candidates) (length prefix))
|
|
candidates)
|
|
;; Implement completion-try-completions interface
|
|
(if (= (length candidates) 1)
|
|
(if (equal infix (car candidates))
|
|
t
|
|
;; Avoid quirk of double / for filename completion. I don't
|
|
;; know how this is *supposed* to be handled.
|
|
(when (and (> (length (car candidates)) 0)
|
|
(> (length suffix) 0)
|
|
(char-equal (aref (car candidates)
|
|
(1- (length (car candidates))))
|
|
(aref suffix 0)))
|
|
(setq suffix (substring suffix 1)))
|
|
(cons (concat prefix (car candidates) suffix)
|
|
(length (concat prefix (car candidates)))))
|
|
(if (= (length infix) 0)
|
|
(cons string point)
|
|
(cl-destructuring-bind (merged . holes)
|
|
(company-flx-merge candidates)
|
|
(cons
|
|
(concat prefix merged suffix)
|
|
(+ (length prefix)
|
|
(cl-position (apply #'max holes) holes)))))))))
|
|
|
|
(defun company-flx-try-completion (string table predicate point)
|
|
"Fuzzy version of completion-try-completion"
|
|
(company-flx-completion string table predicate point))
|
|
(defun company-flx-all-completions (string table predicate point)
|
|
"Fuzzy version of completion-all-completions"
|
|
(company-flx-completion string table predicate point 'all))
|
|
|
|
(defun company-flx-company-capf-advice (old-fun &rest args)
|
|
(let ((completion-styles (list 'fuzzy)))
|
|
(apply old-fun args)))
|
|
|
|
(defun company-flx-transformer (cands)
|
|
"Sort up to company-flx-limit candidates by their flx score."
|
|
(require 'flx)
|
|
(or company-flx-cache
|
|
(setq company-flx-cache (flx-make-string-cache #'flx-get-heatmap-str)))
|
|
|
|
(let ((num-cands (length cands)))
|
|
(mapcar #'car
|
|
(sort (mapcar
|
|
(lambda (cand)
|
|
(cons cand
|
|
(or (car (flx-score cand
|
|
company-prefix
|
|
company-flx-cache))
|
|
most-negative-fixnum)))
|
|
(if (< num-cands company-flx-limit)
|
|
cands
|
|
(let* ((seq (sort cands (lambda (c1 c2)
|
|
(< (length c1)
|
|
(length c2)))))
|
|
(end (min company-flx-limit
|
|
num-cands
|
|
(length seq)))
|
|
(result nil))
|
|
(dotimes (_ end result)
|
|
(push (pop seq) result)))))
|
|
(lambda (c1 c2)
|
|
;; break ties by length
|
|
(if (/= (cdr c1) (cdr c2))
|
|
(> (cdr c1)
|
|
(cdr c2))
|
|
(< (length (car c1))
|
|
(length (car c2)))))))))
|
|
|
|
;;;###autoload
|
|
(define-minor-mode company-flx-mode
|
|
"company-flx minor mode"
|
|
:init-value nil
|
|
:group 'company-flx
|
|
:global t
|
|
(if company-flx-mode
|
|
(progn
|
|
(add-to-list 'completion-styles-alist
|
|
'(fuzzy
|
|
company-flx-try-completion
|
|
company-flx-all-completions
|
|
"An intelligent fuzzy matching completion style."))
|
|
|
|
(advice-add 'company-capf :around #'company-flx-company-capf-advice)
|
|
(add-to-list 'company-transformers #'company-flx-transformer t))
|
|
|
|
(advice-remove 'company-capf #'company-flx-company-capf-advice)
|
|
(setq company-transformers
|
|
(delete #'company-flx-transformer company-transformers))))
|
|
|
|
(provide 'company-flx)
|
|
;;; company-flx.el ends here
|