-
Notifications
You must be signed in to change notification settings - Fork 6
/
Copy pathcompany-flx.el
251 lines (218 loc) · 9.86 KB
/
company-flx.el
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
;;; company-flx.el --- flx based fuzzy matching for company -*- lexical-binding: t -*-
;; Copyright (C) 2015, 2018 PythonNut
;; Author: PythonNut <[email protected]>
;; Keywords: convenience, company, fuzzy, flx
;; 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