1 (eval-when-compile (require 'cl))
3 (add-to-list 'debug-ignored-errors
4 "^Pseudo tooltip frontend cannot be used twice$")
5 (add-to-list 'debug-ignored-errors "^Preview frontend cannot be used twice$")
13 (defface company-tooltip
14 '((t :background "yellow"
19 (defface company-tooltip-selection
20 '((t :background "orange1"
25 (defface company-tooltip-common
26 '((t :inherit company-tooltip
31 (defface company-tooltip-common-selection
32 '((t :inherit company-tooltip-selection
37 (defcustom company-tooltip-limit 10
42 (defface company-preview
43 '((t :background "blue4"
48 (defface company-preview-common
49 '((t :inherit company-preview
54 (defface company-echo nil
58 (defface company-echo-common
59 '((((background dark)) (:foreground "firebrick1"))
60 (((background light)) (:background "firebrick4")))
64 (defun company-frontends-set (variable value)
66 (let ((remainder value))
67 (setcdr remainder (delq (car remainder) (cdr remainder))))
68 (and (memq 'company-pseudo-tooltip-unless-just-one-frontend value)
69 (memq 'company-pseudo-tooltip-frontend value)
70 (error "Pseudo tooltip frontend cannot be used twice"))
71 (and (memq 'company-preview-if-just-one-frontend value)
72 (memq 'company-preview-frontend value)
73 (error "Preview frontend cannot be used twice"))
74 ;; preview must come last
75 (dolist (f '(company-preview-if-just-one-frontend company-preview-frontend))
77 (setq value (append (delq f value) (list f)))))
80 (defcustom company-frontends '(company-echo-frontend
81 company-pseudo-tooltip-unless-just-one-frontend
82 company-preview-if-just-one-frontend)
84 :set 'company-frontends-set
86 :type '(repeat (choice (const :tag "echo" company-echo-frontend)
87 (const :tag "pseudo tooltip"
88 company-pseudo-tooltip-frontend)
89 (const :tag "pseudo tooltip, multiple only"
90 company-pseudo-tooltip-unless-just-one-frontend)
91 (const :tag "preview" company-preview-frontend)
92 (const :tag "preview, unique only"
93 company-preview-if-just-one-frontend)
94 (function :tag "custom function" nil))))
96 (defcustom company-backends '(company-elisp-completion)
99 :type '(repeat (function :tag "function" nil)))
101 (defcustom company-minimum-prefix-length 3
104 :type '(integer :tag "prefix length"))
106 (defvar company-timer nil)
108 (defun company-timer-set (variable value)
110 (when company-timer (cancel-timer company-timer))
111 (when (numberp value)
112 (setq company-timer (run-with-idle-timer value t 'company-idle-begin))))
114 (defcustom company-idle-delay .7
116 :set 'company-timer-set
118 :type '(choice (const :tag "never (nil)" nil)
119 (const :tag "immediate (t)" t)
120 (number :tag "seconds")))
122 ;;; mode ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
124 (defvar company-mode-map
125 (let ((keymap (make-sparse-keymap)))
126 (define-key keymap (kbd "M-n") 'company-select-next)
127 (define-key keymap (kbd "M-p") 'company-select-previous)
128 (define-key keymap (kbd "M-<return>") 'company-complete-selection)
129 (define-key keymap "\t" 'company-complete-common)
133 (define-minor-mode company-mode
135 nil " comp" company-mode-map
138 (add-hook 'pre-command-hook 'company-pre-command nil t)
139 (add-hook 'post-command-hook 'company-post-command nil t)
140 (company-timer-set 'company-idle-delay
142 (remove-hook 'pre-command-hook 'company-pre-command t)
143 (remove-hook 'post-command-hook 'company-post-command t)
145 (kill-local-variable 'company-point)))
147 ;;; backends ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
149 (defun company-grab (regexp &optional expression)
150 (when (looking-back regexp)
151 (or (match-string-no-properties (or expression 0)) "")))
153 (defun company-in-string-or-comment (&optional point)
154 (let ((pos (syntax-ppss)))
155 (or (nth 3 pos) (nth 4 pos) (nth 7 pos))))
159 (defvar company-lisp-symbol-regexp
160 "\\_<\\(\\sw\\|\\s_\\)+\\_>\\=")
162 (defun company-grab-lisp-symbol ()
163 (let ((prefix (or (company-grab company-lisp-symbol-regexp) "")))
164 (unless (and (company-in-string-or-comment (- (point) (length prefix)))
165 (/= (char-before (- (point) (length prefix))) ?`))
168 (defun company-elisp-completion (command &optional arg &rest ignored)
170 ('prefix (and (eq major-mode 'emacs-lisp-mode)
171 (company-grab-lisp-symbol)))
172 ('candidates (let ((completion-ignore-case nil))
173 (all-completions arg obarray
174 (lambda (symbol) (or (boundp symbol)
175 (fboundp symbol))))))))
177 ;;; completion mechanism ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
179 (defvar company-backend nil)
180 (make-variable-buffer-local 'company-backend)
182 (defvar company-prefix nil)
183 (make-variable-buffer-local 'company-prefix)
185 (defvar company-candidates nil)
186 (make-variable-buffer-local 'company-candidates)
188 (defvar company-common nil)
189 (make-variable-buffer-local 'company-common)
191 (defvar company-selection 0)
192 (make-variable-buffer-local 'company-selection)
194 (defvar company-selection-changed nil)
195 (make-variable-buffer-local 'company-selection-changed)
197 (defvar company-point nil)
198 (make-variable-buffer-local 'company-point)
200 (defsubst company-strip-prefix (str)
201 (substring str (length company-prefix)))
203 (defsubst company-offset (display-limit)
204 (let ((offset (- company-selection display-limit -1)))
207 (defsubst company-should-complete (prefix)
208 (and (eq company-idle-delay t)
209 (>= (length prefix) company-minimum-prefix-length)))
211 (defsubst company-call-frontends (command)
212 (dolist (frontend company-frontends)
213 (funcall frontend command)))
215 (defun company-idle-begin ()
217 (not company-candidates)
218 (not (equal (point) company-point))
219 (let ((company-idle-delay t))
221 (company-post-command))))
223 (defun company-manual-begin ()
225 (not company-candidates)
226 (let ((company-idle-delay t)
227 (company-minimum-prefix-length 0))
229 ;; Return non-nil if active.
232 (defun company-continue-or-cancel ()
233 (when company-candidates
234 (let ((old-point (- company-point (length company-prefix)))
235 (company-idle-delay t)
236 (company-minimum-prefix-length 0))
237 ;; TODO: Make more efficient.
238 (setq company-candidates nil)
240 (unless (and company-candidates
241 (equal old-point (- company-point (length company-prefix))))
243 company-candidates)))
245 (defun company-begin ()
246 (or (company-continue-or-cancel)
247 (let ((completion-ignore-case nil) ;; TODO: make this optional
249 (dolist (backend company-backends)
250 (when (setq prefix (funcall backend 'prefix))
251 (when (company-should-complete prefix)
252 (setq company-backend backend
253 company-prefix prefix
255 (funcall company-backend 'candidates prefix)
256 company-common (try-completion prefix company-candidates)
258 company-point (point))
259 (unless (funcall company-backend 'sorted)
260 (setq company-candidates (sort company-candidates 'string<)))
261 (company-call-frontends 'update))
263 (unless (and company-candidates
264 (not (eq t company-common)))
267 (defun company-cancel ()
268 (setq company-backend nil
270 company-candidates nil
273 company-selection-changed nil
275 (company-call-frontends 'hide))
277 (defun company-abort ()
279 ;; Don't start again, unless started manually.
280 (setq company-point (point)))
282 (defun company-pre-command ()
283 (when company-candidates
284 (company-call-frontends 'pre-command)))
286 (defun company-post-command ()
287 (unless (equal (point) company-point)
289 (when company-candidates
290 (company-call-frontends 'post-command)))
292 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
294 (defun company-select-next ()
296 (when (company-manual-begin)
297 (setq company-selection (min (1- (length company-candidates))
298 (1+ company-selection))
299 company-selection-changed t)))
301 (defun company-select-previous ()
303 (when (company-manual-begin)
304 (setq company-selection (max 0 (1- company-selection))
305 company-selection-changed t)))
307 (defun company-complete-selection ()
309 (when (company-manual-begin)
310 (insert (company-strip-prefix (nth company-selection company-candidates)))
313 (defun company-complete-common ()
315 (when (company-manual-begin)
316 (insert (company-strip-prefix company-common))))
318 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
320 (defconst company-space-strings-limit 100)
322 (defconst company-space-strings
324 (dotimes (i company-space-strings-limit)
325 (push (make-string (- company-space-strings-limit 1 i) ?\ ) lst))
326 (apply 'vector lst)))
328 (defsubst company-space-string (len)
329 (if (< len company-space-strings-limit)
330 (aref company-space-strings len)
331 (make-string len ?\ )))
333 (defsubst company-safe-substring (str from &optional to)
334 (let ((len (length str)))
337 (if (and to (> to len))
338 (concat (substring str from)
339 (company-space-string (- to len)))
340 (substring str from to)))))
342 ;;; pseudo-tooltip ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
344 (defvar company-pseudo-tooltip-overlay nil)
345 (make-variable-buffer-local 'company-pseudo-tooltip-overlay)
349 (defun company-fill-propertize (line width selected)
350 (setq line (company-safe-substring line 0 width))
351 (add-text-properties 0 width
352 (list 'face (if selected
353 'company-tooltip-selection
354 'company-tooltip)) line)
355 (add-text-properties 0 (length company-common)
356 (list 'face (if selected
357 'company-tooltip-common-selection
358 'company-tooltip-common)) line)
361 (defun company-fill-propertize-lines (column lines selection)
364 (len (min company-tooltip-limit (length lines)))
367 (setq width (max (length (pop lines-copy)) width)))
368 (setq width (min width (- (window-width) column)))
370 (push (company-fill-propertize (pop lines) width (equal i selection))
376 (defun company-buffer-lines (beg end)
378 (let ((row (cdr (posn-col-row (posn-at-point))))
380 (while (< (point) end)
381 (move-to-window-line (incf row))
382 (push (buffer-substring beg (min end (1- (point)))) lines)
386 (defun company-modify-line (old new offset)
387 (concat (company-safe-substring old 0 offset)
389 (company-safe-substring old (+ offset (length new)))))
391 (defun company-modified-substring (beg end lines column nl)
392 (let ((old (company-buffer-lines beg end))
394 ;; Inject into old lines.
396 (push (company-modify-line (pop old) (pop lines) column) new))
397 ;; Append whole new lines.
399 (push (company-modify-line "" (pop lines) column) new))
400 (concat (when nl "\n")
401 (mapconcat 'identity (nreverse new) "\n")
406 (defun company-pseudo-tooltip-show (row column lines selection)
407 (company-pseudo-tooltip-hide)
408 (unless lines (error "No text provided"))
412 (let ((offset (company-offset company-tooltip-limit)))
413 (setq lines (nthcdr offset lines))
414 (decf selection offset))
416 (setq lines (company-fill-propertize-lines column lines selection))
421 (let ((nl (< (move-to-window-line row) row))
424 (move-to-window-line (min (window-height)
425 (+ row company-tooltip-limit)))
429 (setq company-pseudo-tooltip-overlay (make-overlay beg end))
431 (overlay-put company-pseudo-tooltip-overlay 'before-string
432 (company-modified-substring beg end lines column nl))
433 (overlay-put company-pseudo-tooltip-overlay 'invisible t)
434 (overlay-put company-pseudo-tooltip-overlay 'window (selected-window)))))
436 (defun company-pseudo-tooltip-show-at-point (pos)
437 (let ((col-row (posn-col-row (posn-at-point pos))))
438 (company-pseudo-tooltip-show (1+ (cdr col-row)) (car col-row)
439 company-candidates company-selection)))
441 (defun company-pseudo-tooltip-hide ()
442 (when company-pseudo-tooltip-overlay
443 (delete-overlay company-pseudo-tooltip-overlay)
444 (setq company-pseudo-tooltip-overlay nil)))
446 (defun company-pseudo-tooltip-frontend (command)
448 ('pre-command (company-pseudo-tooltip-hide))
449 ('post-command (company-pseudo-tooltip-show-at-point
450 (- (point) (length company-prefix))))
451 ('hide (company-pseudo-tooltip-hide))))
453 (defun company-pseudo-tooltip-unless-just-one-frontend (command)
454 (unless (and (eq command 'post-command)
455 (not (cdr company-candidates)))
456 (company-pseudo-tooltip-frontend command)))
458 ;;; overlay ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
460 (defvar company-preview-overlay nil)
461 (make-variable-buffer-local 'company-preview-overlay)
463 (defun company-preview-show-at-point (pos)
464 (company-preview-hide)
466 (setq company-preview-overlay (make-overlay pos pos))
468 (let ((completion (company-strip-prefix (nth company-selection
469 company-candidates))))
470 (and (equal pos (point))
471 (not (equal completion ""))
472 (add-text-properties 0 1 '(cursor t) completion))
474 (setq completion (propertize completion 'face 'company-preview))
475 (add-text-properties 0 (- (length company-common) (length company-prefix))
476 '(face company-preview-common) completion)
478 (overlay-put company-preview-overlay 'after-string completion)
479 (overlay-put company-preview-overlay 'window (selected-window))))
481 (defun company-preview-hide ()
482 (when company-preview-overlay
483 (delete-overlay company-preview-overlay)
484 (setq company-preview-overlay nil)))
486 (defun company-preview-frontend (command)
488 ('pre-command (company-preview-hide))
489 ('post-command (company-preview-show-at-point (point)))
490 ('hide (company-preview-hide))))
492 (defun company-preview-if-just-one-frontend (command)
493 (unless (and (eq command 'post-command)
494 (cdr company-candidates))
495 (company-preview-frontend command)))
497 ;;; echo ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
499 (defvar company-echo-last-msg nil)
500 (make-variable-buffer-local 'company-echo-last-msg)
502 (defun company-echo-refresh ()
503 (let ((message-log-max nil))
504 (if company-echo-last-msg
505 (message "%s" company-echo-last-msg)
508 (defun company-echo-show (candidates)
510 ;; Roll to selection.
511 (setq candidates (nthcdr company-selection candidates))
513 (let ((limit (window-width (minibuffer-window)))
517 (setq comp (pop candidates)
518 len (+ len 1 (length comp)))
520 (setq candidates nil)
521 (setq comp (propertize comp 'face 'company-echo))
522 (add-text-properties 0 (length company-common)
523 '(face company-echo-common) comp)
526 (setq company-echo-last-msg (mapconcat 'identity (nreverse msg) " "))
527 (company-echo-refresh)))
529 (defun company-echo-frontend (command)
531 ('pre-command (company-echo-refresh))
532 ('post-command (company-echo-show company-candidates))
533 ('hide (setq company-echo-last-msg nil))))
536 ;;; company.el ends here