From 4c740d6f8d321988caff67fcfca3cbadb36002f7 Mon Sep 17 00:00:00 2001 From: Daniel Weschke Date: Mon, 3 Jan 2022 21:18:11 +0100 Subject: [PATCH] update packages --- lisp/biblio-core.el | 30 +- lisp/biblio/biblio-doi.el | 4 +- lisp/biblio/biblio-pkg.el | 10 +- lisp/bibtex-completion.el | 52 +- lisp/bind-key.el | 67 +- lisp/company-ledger.el | 29 +- lisp/company-quickhelp.el | 37 +- lisp/company/company-abbrev.el | 6 +- lisp/company/company-capf.el | 21 +- lisp/company/company-clang.el | 34 +- lisp/company/company-dabbrev-code.el | 1 + lisp/company/company-dabbrev.el | 1 + lisp/company/company-files.el | 20 +- lisp/company/company-gtags.el | 23 +- lisp/company/company-ispell.el | 1 + lisp/company/company-keywords.el | 40 +- lisp/company/company-pkg.el | 6 +- lisp/company/company-tng.el | 37 +- lisp/company/company-yasnippet.el | 21 +- lisp/company/company.el | 1136 ++++++--- lisp/company/company.info | 1710 +++++++++++++ lisp/company/dir | 18 + lisp/company/icons/LICENSE | 395 +++ lisp/company/icons/attribution.md | 5 + lisp/company/icons/vscode-dark/folder.svg | 3 + lisp/company/icons/vscode-dark/references.svg | 3 + .../icons/vscode-dark/symbol-array.svg | 3 + .../icons/vscode-dark/symbol-boolean.svg | 3 + .../icons/vscode-dark/symbol-class.svg | 3 + .../icons/vscode-dark/symbol-color.svg | 3 + .../icons/vscode-dark/symbol-constant.svg | 4 + .../vscode-dark/symbol-enumerator-member.svg | 3 + .../icons/vscode-dark/symbol-enumerator.svg | 3 + .../icons/vscode-dark/symbol-event.svg | 3 + .../icons/vscode-dark/symbol-field.svg | 3 + .../company/icons/vscode-dark/symbol-file.svg | 3 + .../icons/vscode-dark/symbol-interface.svg | 3 + lisp/company/icons/vscode-dark/symbol-key.svg | 3 + .../icons/vscode-dark/symbol-keyword.svg | 3 + .../icons/vscode-dark/symbol-method.svg | 3 + .../company/icons/vscode-dark/symbol-misc.svg | 3 + .../icons/vscode-dark/symbol-namespace.svg | 3 + .../icons/vscode-dark/symbol-numeric.svg | 3 + .../icons/vscode-dark/symbol-operator.svg | 3 + .../icons/vscode-dark/symbol-parameter.svg | 3 + .../icons/vscode-dark/symbol-property.svg | 3 + .../icons/vscode-dark/symbol-ruler.svg | 3 + .../icons/vscode-dark/symbol-snippet.svg | 3 + .../icons/vscode-dark/symbol-string.svg | 3 + .../icons/vscode-dark/symbol-structure.svg | 3 + .../icons/vscode-dark/symbol-variable.svg | 3 + lisp/company/icons/vscode-light/folder.svg | 3 + .../company/icons/vscode-light/references.svg | 10 + .../icons/vscode-light/symbol-array.svg | 3 + .../icons/vscode-light/symbol-boolean.svg | 3 + .../icons/vscode-light/symbol-class.svg | 3 + .../icons/vscode-light/symbol-color.svg | 3 + .../icons/vscode-light/symbol-constant.svg | 4 + .../vscode-light/symbol-enumerator-member.svg | 3 + .../icons/vscode-light/symbol-enumerator.svg | 3 + .../icons/vscode-light/symbol-event.svg | 3 + .../icons/vscode-light/symbol-field.svg | 3 + .../icons/vscode-light/symbol-file.svg | 3 + .../icons/vscode-light/symbol-interface.svg | 3 + .../company/icons/vscode-light/symbol-key.svg | 3 + .../icons/vscode-light/symbol-keyword.svg | 3 + .../icons/vscode-light/symbol-method.svg | 3 + .../icons/vscode-light/symbol-misc.svg | 3 + .../icons/vscode-light/symbol-namespace.svg | 10 + .../icons/vscode-light/symbol-numeric.svg | 3 + .../icons/vscode-light/symbol-operator.svg | 3 + .../icons/vscode-light/symbol-parameter.svg | 3 + .../icons/vscode-light/symbol-property.svg | 3 + .../icons/vscode-light/symbol-ruler.svg | 3 + .../icons/vscode-light/symbol-snippet.svg | 3 + .../icons/vscode-light/symbol-string.svg | 3 + .../icons/vscode-light/symbol-structure.svg | 3 + .../icons/vscode-light/symbol-variable.svg | 3 + lisp/counsel.el | 308 ++- lisp/crdt.el | 2207 +++++++++++------ lisp/ctable.el | 172 +- lisp/ivy/colir.el | 2 +- lisp/ivy/ivy-faces.el | 2 +- lisp/ivy/ivy-overlay.el | 2 +- lisp/ivy/ivy-pkg.el | 4 +- lisp/ivy/ivy.el | 362 ++- lisp/ivy/ivy.info | 239 +- lisp/swiper.el | 132 +- lisp/versions | 32 +- 89 files changed, 5691 insertions(+), 1653 deletions(-) create mode 100644 lisp/company/company.info create mode 100644 lisp/company/dir create mode 100644 lisp/company/icons/LICENSE create mode 100644 lisp/company/icons/attribution.md create mode 100644 lisp/company/icons/vscode-dark/folder.svg create mode 100644 lisp/company/icons/vscode-dark/references.svg create mode 100644 lisp/company/icons/vscode-dark/symbol-array.svg create mode 100644 lisp/company/icons/vscode-dark/symbol-boolean.svg create mode 100644 lisp/company/icons/vscode-dark/symbol-class.svg create mode 100644 lisp/company/icons/vscode-dark/symbol-color.svg create mode 100644 lisp/company/icons/vscode-dark/symbol-constant.svg create mode 100644 lisp/company/icons/vscode-dark/symbol-enumerator-member.svg create mode 100644 lisp/company/icons/vscode-dark/symbol-enumerator.svg create mode 100644 lisp/company/icons/vscode-dark/symbol-event.svg create mode 100644 lisp/company/icons/vscode-dark/symbol-field.svg create mode 100644 lisp/company/icons/vscode-dark/symbol-file.svg create mode 100644 lisp/company/icons/vscode-dark/symbol-interface.svg create mode 100644 lisp/company/icons/vscode-dark/symbol-key.svg create mode 100644 lisp/company/icons/vscode-dark/symbol-keyword.svg create mode 100644 lisp/company/icons/vscode-dark/symbol-method.svg create mode 100644 lisp/company/icons/vscode-dark/symbol-misc.svg create mode 100644 lisp/company/icons/vscode-dark/symbol-namespace.svg create mode 100644 lisp/company/icons/vscode-dark/symbol-numeric.svg create mode 100644 lisp/company/icons/vscode-dark/symbol-operator.svg create mode 100644 lisp/company/icons/vscode-dark/symbol-parameter.svg create mode 100644 lisp/company/icons/vscode-dark/symbol-property.svg create mode 100644 lisp/company/icons/vscode-dark/symbol-ruler.svg create mode 100644 lisp/company/icons/vscode-dark/symbol-snippet.svg create mode 100644 lisp/company/icons/vscode-dark/symbol-string.svg create mode 100644 lisp/company/icons/vscode-dark/symbol-structure.svg create mode 100644 lisp/company/icons/vscode-dark/symbol-variable.svg create mode 100644 lisp/company/icons/vscode-light/folder.svg create mode 100644 lisp/company/icons/vscode-light/references.svg create mode 100644 lisp/company/icons/vscode-light/symbol-array.svg create mode 100644 lisp/company/icons/vscode-light/symbol-boolean.svg create mode 100644 lisp/company/icons/vscode-light/symbol-class.svg create mode 100644 lisp/company/icons/vscode-light/symbol-color.svg create mode 100644 lisp/company/icons/vscode-light/symbol-constant.svg create mode 100644 lisp/company/icons/vscode-light/symbol-enumerator-member.svg create mode 100644 lisp/company/icons/vscode-light/symbol-enumerator.svg create mode 100644 lisp/company/icons/vscode-light/symbol-event.svg create mode 100644 lisp/company/icons/vscode-light/symbol-field.svg create mode 100644 lisp/company/icons/vscode-light/symbol-file.svg create mode 100644 lisp/company/icons/vscode-light/symbol-interface.svg create mode 100644 lisp/company/icons/vscode-light/symbol-key.svg create mode 100644 lisp/company/icons/vscode-light/symbol-keyword.svg create mode 100644 lisp/company/icons/vscode-light/symbol-method.svg create mode 100644 lisp/company/icons/vscode-light/symbol-misc.svg create mode 100644 lisp/company/icons/vscode-light/symbol-namespace.svg create mode 100644 lisp/company/icons/vscode-light/symbol-numeric.svg create mode 100644 lisp/company/icons/vscode-light/symbol-operator.svg create mode 100644 lisp/company/icons/vscode-light/symbol-parameter.svg create mode 100644 lisp/company/icons/vscode-light/symbol-property.svg create mode 100644 lisp/company/icons/vscode-light/symbol-ruler.svg create mode 100644 lisp/company/icons/vscode-light/symbol-snippet.svg create mode 100644 lisp/company/icons/vscode-light/symbol-string.svg create mode 100644 lisp/company/icons/vscode-light/symbol-structure.svg create mode 100644 lisp/company/icons/vscode-light/symbol-variable.svg diff --git a/lisp/biblio-core.el b/lisp/biblio-core.el index 58b7f62f..deb97aab 100644 --- a/lisp/biblio-core.el +++ b/lisp/biblio-core.el @@ -4,8 +4,8 @@ ;; Author: Clément Pit-Claudel ;; Version: 0.2.1 -;; Package-Version: 20200416.307 -;; Package-Commit: eb9baf1d2bf6a073d24ccb717025baa693e98f3e +;; Package-Version: 20210418.406 +;; Package-Commit: 517ec18f00f91b61481214b178f7ae0b8fbc499b ;; Package-Requires: ((emacs "24.3") (let-alist "1.0.4") (seq "1.11") (dash "2.12.1")) ;; Keywords: bib, tex, convenience, hypermedia ;; URL: https://github.com/cpitclaudel/biblio.el @@ -294,7 +294,7 @@ non-sparse keymaps." "Return a list of bindings in V, prefixed by K." (biblio--flatten-map v (biblio--as-list k))) keymap))))) - ;; This breaks if keymap is a symbol whose function cell is a keymap + ;; FIXME This breaks if keymap is a symbol whose function cell is a keymap ((symbolp keymap) (list (cons prefix keymap)))))) @@ -329,12 +329,14 @@ That is, if two key map to `eq' values, they are grouped." (defun biblio--help-with-major-mode-1 (keyseqs-command) "Print help on KEYSEQS-COMMAND to standard output." - ;; (biblio-with-fontification 'font-lock-function-name-face - (insert (format "%s (%S)\n" - (biblio--quote-keys (car keyseqs-command)) - (cdr keyseqs-command))) - (biblio-with-fontification 'font-lock-doc-face - (insert (format " %s\n\n" (biblio--brief-docs (cdr keyseqs-command)))))) + (insert (biblio--quote-keys (car keyseqs-command)) " ") + (insert (propertize "\t" 'display '(space :align-to 10))) + (insert-text-button (format "%S" (cdr keyseqs-command))) + (insert "\n") + (biblio-with-fontification '(font-lock-comment-face (:height 0.95)) + (insert (format " %s\n" (biblio--brief-docs (cdr keyseqs-command))))) + (biblio-with-fontification '(:height 0.3) + (insert "\n"))) (defun biblio--help-with-major-mode () "Display help with current major mode." @@ -530,8 +532,10 @@ Interactively, query for ACTION from (let ((map (make-sparse-keymap))) (define-key map (kbd "") #'biblio--selection-previous) (define-key map (kbd "C-p") #'biblio--selection-previous) + (define-key map (kbd "p") #'biblio--selection-previous) (define-key map (kbd "") #'biblio--selection-next) (define-key map (kbd "C-n") #'biblio--selection-next) + (define-key map (kbd "n") #'biblio--selection-next) (define-key map (kbd "RET") #'biblio--selection-browse) (define-key map (kbd "") #'biblio--selection-browse-direct) (define-key map (kbd "C-RET") #'biblio--selection-browse-direct) @@ -560,10 +564,16 @@ Interactively, query for ACTION from (buffer-name biblio--target-buffer)) ""))) +(defface biblio-highlight-extend-face `((t (:inherit highlight + ,@(and (>= emacs-major-version 27) '(:extend t))))) + "Face used for highlighting lines." + :group 'biblio-faces) + (define-derived-mode biblio-selection-mode fundamental-mode biblio--selection-mode-name-base "Browse bibliographic search results. \\{biblio-selection-mode-map}" - (hl-line-mode) + (setq-local hl-line-face 'biblio-highlight-extend-face) + (hl-line-mode 1) (visual-line-mode) (setq-local truncate-lines nil) (setq-local cursor-type nil) diff --git a/lisp/biblio/biblio-doi.el b/lisp/biblio/biblio-doi.el index eb28ee64..308d4efe 100644 --- a/lisp/biblio/biblio-doi.el +++ b/lisp/biblio/biblio-doi.el @@ -109,7 +109,7 @@ FORWARD-TO is the callback to call with the results of the search." (biblio-doi--forward-bibtex-crosscite doi forward-to))))) ;;;###autoload -(defun doi-insert-bibtex (doi) +(defun biblio-doi-insert-bibtex (doi) "Insert BibTeX entry matching DOI." (interactive "MDOI: ") (let ((target-buffer (current-buffer))) @@ -120,5 +120,7 @@ FORWARD-TO is the callback to call with the results of the search." (biblio-format-bibtex result biblio-bibtex-use-autokey) target-buffer))))) +(defalias 'doi-insert-bibtex 'biblio-doi-insert-bibtex) + (provide 'biblio-doi) ;;; biblio-doi.el ends here diff --git a/lisp/biblio/biblio-pkg.el b/lisp/biblio/biblio-pkg.el index 29d22b79..3cbf401f 100644 --- a/lisp/biblio/biblio-pkg.el +++ b/lisp/biblio/biblio-pkg.el @@ -1,7 +1,13 @@ -(define-package "biblio" "20200416.1407" "Browse and import bibliographic references from CrossRef, arXiv, DBLP, HAL, Dissemin, and doi.org" +(define-package "biblio" "20210418.406" "Browse and import bibliographic references from CrossRef, arXiv, DBLP, HAL, Dissemin, and doi.org" '((emacs "24.3") (biblio-core "0.2")) - :commit "eb9baf1d2bf6a073d24ccb717025baa693e98f3e") + :commit "517ec18f00f91b61481214b178f7ae0b8fbc499b" :authors + '(("Clément Pit-Claudel" . "clement.pitclaudel@live.com")) + :maintainer + '("Clément Pit-Claudel" . "clement.pitclaudel@live.com") + :keywords + '("bib" "tex" "convenience" "hypermedia") + :url "https://github.com/cpitclaudel/biblio.el") ;; Local Variables: ;; no-byte-compile: t ;; End: diff --git a/lisp/bibtex-completion.el b/lisp/bibtex-completion.el index ac0d4f6f..dc08f3c5 100644 --- a/lisp/bibtex-completion.el +++ b/lisp/bibtex-completion.el @@ -4,8 +4,8 @@ ;; Justin Burkett ;; Maintainer: Titus von der Malsburg ;; URL: https://github.com/tmalsburg/helm-bibtex -;; Package-Version: 20200908.1017 -;; Package-Commit: 1bb81d77e08296a50de7ebfe5cf5b0c715b7f3d6 +;; Package-Version: 20211019.1306 +;; Package-Commit: aa775340ba691d2322948bfdc6a88158568a1399 ;; Version: 1.0.0 ;; Package-Requires: ((parsebib "1.0") (s "1.9.0") (dash "2.6.0") (f "0.16.2") (cl-lib "0.5") (biblio "0.2") (emacs "26.1")) @@ -70,6 +70,8 @@ different name, use a cons cell `(\"orgfile.org\" . \"bibfile.bib\")' instead." :group 'bibtex-completion :type '(choice file (repeat file))) +;;;###autoload (put 'bibtex-completion-bibliography 'safe-local-variable 'stringp) + (defcustom bibtex-completion-library-path nil "A directory or list of directories in which PDFs are stored. Bibtex-completion assumes that the names of these PDFs are @@ -124,7 +126,7 @@ ebib:key depending on the major mode of the current buffer. Note that the functions should accept a list of keys as input. With multiple marked entries one can insert multiple keys at once, e.g. \cite{key1,key2}. See the functions -`bibtex-completion-format-citation-ebib' and +`bibtex-completion-format-citation-org-cite' and `bibtex-completion-format-citation-cite' as examples." :group 'bibtex-completion :type '(alist :key-type symbol :value-type function)) @@ -640,9 +642,11 @@ the hash table." (defun bibtex-completion-make-candidate (entry) "Return a candidate for ENTRY." - (cons (bibtex-completion-clean-string - (s-join " " (-map #'cdr entry))) - entry)) + (let* ((candidate (bibtex-completion-clean-string + (s-join " " (-map #'cdr entry)))) + (candidate (concat candidate " " (car (assoc "=has-pdf=" entry)))) + (candidate (concat candidate " " (car (assoc "=has-note=" entry))))) + (cons candidate entry))) (defun bibtex-completion-parse-bibliography (&optional ht-strings) "Parse the BibTeX entries listed in the current buffer and return a list of entries in the order in which they appeared in the BibTeX file. @@ -707,8 +711,8 @@ does not exist, or if `bibtex-completion-pdf-field' is nil." ((not value) nil) ; Field not defined. ((f-file? value) (list value)) ; A bare full path was found. ((-any 'f-file? (--map (f-join it (f-filename value)) (-flatten bibtex-completion-library-path))) (-filter 'f-file? (--map (f-join it (f-filename value)) (-flatten bibtex-completion-library-path)))) - (t ; Zotero/Mendeley/JabRef format: - (let ((value (replace-regexp-in-string "\\([^\\]\\);" "\\1\^^" value))) + (t ; Zotero/Mendeley/JabRef/Calibre format: + (let ((value (replace-regexp-in-string "\\([^\\]\\)[;,]" "\\1\^^" value))) (cl-loop ; Looping over the files: for record in (s-split "\^^" value) ; Replace unescaped colons by field separator: @@ -1047,6 +1051,12 @@ which no PDF is available are omitted." for pdfs = (bibtex-completion-find-pdf key bibtex-completion-find-additional-pdfs) append (with-no-warnings (--map (org-make-link-string it key) pdfs))))) +(defun bibtex-completion-format-citation-org-cite (keys) + "Format org-links using Org mode's own cite syntax." + (format "[cite:%s]" + (s-join ";" + (--map (format "@%s" it) keys)))) + (defun bibtex-completion-format-citation-org-apa-link-to-PDF (keys) "Format org-links to PDF for entries in KEYS. Link text loosely follows APA format. Uses first matching PDF if @@ -1123,7 +1133,7 @@ The format depends on 'bibtex-completion-apa-get-value entry)) ("inbook" (s-format - "${author} (${year}). ${title}. In ${editor} (Eds.), ${booktitle} (pp. ${pages}). ${address}: ${publisher}." + "${author} (${year}). ${chapter}. In ${editor} (Eds.), ${title} (pp. ${pages}). ${address}: ${publisher}." 'bibtex-completion-apa-get-value entry)) ("incollection" (s-format @@ -1204,7 +1214,7 @@ Return DEFAULT if FIELD is not present in ENTRY." ("year" (or value (car (split-string (bibtex-completion-get-value "date" entry "") "-")))) (_ value)) - ""))))) + (or default "")))))) (defun bibtex-completion-apa-format-authors (value &optional abbrev) "Format author list in VALUE in APA style. @@ -1290,7 +1300,10 @@ Surrounding curly braces are stripped." (replace-regexp-in-string "\\(^[[:space:]]*[\"{][[:space:]]*\\)\\|\\([[:space:]]*[\"}][[:space:]]*$\\)" "" - (s-collapse-whitespace value)) + ;; Collapse whitespaces when the content is not a path: + (if (equal bibtex-completion-pdf-field field) + value + (s-collapse-whitespace value))) default))) (defun bibtex-completion-insert-key (keys) @@ -1535,15 +1548,24 @@ bibliography file that will open that file for editing." (defun bibtex-completion-find-local-bibliography () "Return a list of BibTeX files associated with the current file. -If the current file is a BibTeX file, return this -file. Otherwise, try to use `reftex' to find the associated -BibTeX files. If this fails, return nil." + +If the current file is a BibTeX file, return this file. In LaTeX +documents, use `reftex' to find associated BibTeX files. In org +files return the local or global org bibliography (see oc.el). +If all fails, return nil." (or (and (buffer-file-name) (string= (or (f-ext (buffer-file-name)) "") "bib") (list (buffer-file-name))) + ;; LaTeX: (and (buffer-file-name) + (string= (or (f-ext (buffer-file-name)) "") "tex") (require 'reftex-cite nil t) - (ignore-errors (reftex-get-bibfile-list))))) + (ignore-errors (reftex-get-bibfile-list))) + ;; Org (with oc.el): + (and (buffer-file-name) + (string= (or (f-ext (buffer-file-name)) "") "org") + (fboundp 'org-cite-list-bibliography-files) + (org-cite-list-bibliography-files)))) (defun bibtex-completion-get-key-bibtex () "Return the key of the BibTeX entry at point, nil otherwise. diff --git a/lisp/bind-key.el b/lisp/bind-key.el index bb232efe..78c64780 100644 --- a/lisp/bind-key.el +++ b/lisp/bind-key.el @@ -7,8 +7,8 @@ ;; Created: 16 Jun 2012 ;; Modified: 29 Nov 2017 ;; Version: 2.4 -;; Package-Version: 20200805.1727 -;; Package-Commit: 365c73d2618dd0040a32c2601c5456ab5495b812 +;; Package-Version: 20210210.1609 +;; Package-Commit: a7422fb8ab1baee19adb2717b5b47b9c3812a84c ;; Keywords: keys keybinding config dotemacs ;; URL: https://github.com/jwiegley/use-package @@ -170,16 +170,19 @@ or operates on menu data structures, so you should write it so it can safely be called at any time." (let ((namevar (make-symbol "name")) (keyvar (make-symbol "key")) + (kmapvar (make-symbol "kmap")) (kdescvar (make-symbol "kdesc")) (bindingvar (make-symbol "binding"))) `(let* ((,namevar ,key-name) (,keyvar (if (vectorp ,namevar) ,namevar (read-kbd-macro ,namevar))) - (kmap (if (and ,keymap (symbolp ,keymap)) (symbol-value ,keymap) ,keymap)) + (,kmapvar (or (if (and ,keymap (symbolp ,keymap)) + (symbol-value ,keymap) ,keymap) + global-map)) (,kdescvar (cons (if (stringp ,namevar) ,namevar (key-description ,namevar)) (if (symbolp ,keymap) ,keymap (quote ,keymap)))) - (,bindingvar (lookup-key (or kmap global-map) ,keyvar))) + (,bindingvar (lookup-key ,kmapvar ,keyvar))) (let ((entry (assoc ,kdescvar personal-keybindings)) (details (list ,command (unless (numberp ,bindingvar) @@ -188,27 +191,57 @@ can safely be called at any time." (setcdr entry details) (add-to-list 'personal-keybindings (cons ,kdescvar details)))) ,(if predicate - `(define-key (or kmap global-map) ,keyvar + `(define-key ,kmapvar ,keyvar '(menu-item "" nil :filter (lambda (&optional _) (when ,predicate ,command)))) - `(define-key (or kmap global-map) ,keyvar ,command))))) + `(define-key ,kmapvar ,keyvar ,command))))) ;;;###autoload (defmacro unbind-key (key-name &optional keymap) "Unbind the given KEY-NAME, within the KEYMAP (if specified). See `bind-key' for more details." - `(progn - (bind-key ,key-name nil ,keymap) - (setq personal-keybindings - (cl-delete-if #'(lambda (k) - ,(if keymap - `(and (consp (car k)) - (string= (caar k) ,key-name) - (eq (cdar k) ',keymap)) - `(and (stringp (car k)) - (string= (car k) ,key-name)))) - personal-keybindings)))) + (let ((namevar (make-symbol "name")) + (kdescvar (make-symbol "kdesc"))) + `(let* ((,namevar ,key-name) + (,kdescvar (cons (if (stringp ,namevar) ,namevar + (key-description ,namevar)) + (if (symbolp ,keymap) ,keymap (quote ,keymap))))) + (bind-key--remove (if (vectorp ,namevar) ,namevar + (read-kbd-macro ,namevar)) + (or (if (and ,keymap (symbolp ,keymap)) + (symbol-value ,keymap) ,keymap) + global-map)) + (setq personal-keybindings + (cl-delete-if (lambda (k) (equal (car k) ,kdescvar)) + personal-keybindings)) + nil))) + +(defun bind-key--remove (key keymap) + "Remove KEY from KEYMAP. + +In contrast to `define-key', this function removes the binding from the keymap." + (define-key keymap key nil) + ;; Split M-key in ESC key + (setq key (mapcan (lambda (k) + (if (and (integerp k) (/= (logand k ?\M-\0) 0)) + (list ?\e (logxor k ?\M-\0)) + (list k))) + key)) + ;; Delete single keys directly + (if (= (length key) 1) + (delete key keymap) + ;; Lookup submap and delete key from there + (let* ((prefix (vconcat (butlast key))) + (submap (lookup-key keymap prefix))) + (unless (keymapp submap) + (error "Not a keymap for %s" key)) + (when (symbolp submap) + (setq submap (symbol-function submap))) + (delete (last key) submap) + ;; Delete submap if it is empty + (when (= 1 (length submap)) + (bind-key--remove prefix keymap))))) ;;;###autoload (defmacro bind-key* (key-name command &optional predicate) diff --git a/lisp/company-ledger.el b/lisp/company-ledger.el index 75e877c7..52ab3e01 100644 --- a/lisp/company-ledger.el +++ b/lisp/company-ledger.el @@ -5,8 +5,8 @@ ;; Author: Debanjum Singh Solanky ;; Description: Fuzzy auto-completion for ledger & friends ;; Keywords: abbrev, matching, auto-complete, beancount, ledger, company -;; Package-Version: 20200726.1825 -;; Package-Commit: 9fe9e3b809d6d2bc13c601953f696f43b09ea296 +;; Package-Version: 20210910.250 +;; Package-Commit: c6911b7e39b29c0d5f2541392ff485b0f53fd366 ;; Version: 0.1.0 ;; Package-Requires: ((emacs "24.3") (company "0.8.0")) ;; URL: https://github.com/debanjum/company-ledger @@ -62,6 +62,12 @@ (require 'cl-lib) (require 'company) +(defconst company-ledger-date-regexp "^[0-9]\\{4\\}[-/][0-9]\\{2\\}[-/][0-9]\\{2\\}" + "A regular expression to match lines beginning with dates.") + +(defconst company-ledger-empty-line-regexp "^[ \t]*$" + "A regular expression to match empty lines.") + (defun company-ledger--regexp-filter (regexp list) "Use REGEXP to filter LIST of strings." (let (new) @@ -71,11 +77,11 @@ new)) (defun company-ledger--get-all-postings () - "Get all paragraphs in buffer containing YYYY[-/]MM[-/]DD in them." + "Get all paragraphs in buffer starting with dates." (company-ledger--regexp-filter - "[0-9][0-9][0-9][0-9][-/][0-9][0-9][-/][0-9][0-9]" + company-ledger-date-regexp (mapcar (lambda (s) (substring s 1)) - (split-string (buffer-string) "^$" t)))) + (split-string (buffer-string) company-ledger-empty-line-regexp t)))) (defun company-ledger--fuzzy-word-match (prefix candidate) "Return non-nil if each (partial) word in PREFIX is also in CANDIDATE." @@ -90,7 +96,7 @@ (save-excursion (beginning-of-line) (forward-line 1) - (or (looking-at "[[:space:]]*$") + (or (looking-at company-ledger-empty-line-regexp) (eolp) (eobp)))) @@ -99,19 +105,20 @@ "Fuzzy company back-end for ledger, beancount and other ledger-like modes. Provide completion info based on COMMAND and ARG. IGNORED, not used." (interactive (list 'interactive)) - (cl-case command - (interactive (company-begin-backend 'company-ledger)) + (pcase command + (`interactive (company-begin-backend 'company-ledger)) - (prefix (and (or (bound-and-true-p beancount-mode) + (`prefix (and (or (eq major-mode 'beancount-mode) (derived-mode-p 'ledger-mode)) (company-ledger--next-line-empty-p) (thing-at-point 'line t))) - (candidates + (`candidates (cl-remove-if-not (lambda (c) (company-ledger--fuzzy-word-match arg c)) (company-ledger--get-all-postings))) - (sorted t))) + + (`sorted t))) (provide 'company-ledger) ;;; company-ledger.el ends here diff --git a/lisp/company-quickhelp.el b/lisp/company-quickhelp.el index f94e436c..43f312f8 100644 --- a/lisp/company-quickhelp.el +++ b/lisp/company-quickhelp.el @@ -4,8 +4,8 @@ ;; Author: Lars Andersen ;; URL: https://www.github.com/expez/company-quickhelp -;; Package-Version: 20201208.2308 -;; Package-Commit: b13ff1ba0d6176825f165920b17625948f1256c5 +;; Package-Version: 20211115.1335 +;; Package-Commit: 3ca2708b4e5190205aca01d65fe1b391963a53f9 ;; Keywords: company popup documentation quickhelp ;; Version: 2.2.0 ;; Package-Requires: ((emacs "24.3") (company "0.8.9") (pos-tip "0.4.6")) @@ -46,7 +46,7 @@ "Documentation popups for `company-mode'" :group 'company) -(defcustom company-quickhelp-use-propertized-text nil +(defcustom company-quickhelp-use-propertized-text t "Allow the text to have properties like color, font size, etc." :type '(choice (boolean :tag "Allow")) :group 'company-quickhelp) @@ -130,14 +130,14 @@ resolve ambiguous documentation requests. Instead of failing we just grab the first candidate and press forward." (car candidates)) -(defun company-quickhelp--fetch-docstring (backend) - "Fetch docstring from BACKEND." - (let ((quickhelp-str (company-call-backend 'quickhelp-string backend))) +(defun company-quickhelp--fetch-docstring (selected) + "Fetch docstring from the current backend for SELECTED string." + (let ((quickhelp-str (company-call-backend 'quickhelp-string selected))) (if (stringp quickhelp-str) (with-temp-buffer (insert quickhelp-str) (company-quickhelp--docstring-from-buffer (point-min))) - (let ((doc (company-call-backend 'doc-buffer backend))) + (let ((doc (company-call-backend 'doc-buffer selected))) (when doc ;; The company backend can either return a buffer with the doc or a ;; cons containing the doc buffer and a position at which to start @@ -148,15 +148,16 @@ just grab the first candidate and press forward." (company-quickhelp--docstring-from-buffer (or doc-begin (point-min)))))))))) (defun company-quickhelp--doc (selected) - (cl-letf (((symbol-function 'completing-read) - #'company-quickhelp--completing-read)) - (let* ((doc-and-meta (company-quickhelp--fetch-docstring selected)) - (truncated (plist-get doc-and-meta :truncated)) - (doc (plist-get doc-and-meta :doc))) - (unless (member doc '(nil "")) - (if truncated - (concat doc "\n\n[...]") - doc))))) + (let ((message-log-max nil) (inhibit-message t)) + (cl-letf (((symbol-function 'completing-read) + #'company-quickhelp--completing-read)) + (let* ((doc-and-meta (company-quickhelp--fetch-docstring selected)) + (truncated (plist-get doc-and-meta :truncated)) + (doc (plist-get doc-and-meta :doc))) + (unless (member doc '(nil "")) + (if truncated + (concat doc "\n\n[...]") + doc)))))) (defun company-quickhelp-manual-begin () "Manually trigger the `company-quickhelp' popup for the @@ -206,7 +207,7 @@ currently active `company' completion candidate." (w-h (pos-tip-string-width-height doc))) (cond ((> (car w-h) width) - (setq doc (pos-tip-fill-string doc width nil 'none nil max-height) + (setq doc (pos-tip-fill-string doc width nil nil nil max-height) w-h (pos-tip-string-width-height doc))) ((or (> (car w-h) max-width) (> (cdr w-h) max-height)) @@ -221,7 +222,7 @@ currently active `company' completion candidate." (defun company-quickhelp--set-timer () (when (or (null company-quickhelp--timer) - (eq this-command #'company-quickhelp-manual-begin)) + (eq this-command #'company-quickhelp-manual-begin)) (setq company-quickhelp--timer (run-with-idle-timer company-quickhelp-delay nil 'company-quickhelp--show)))) diff --git a/lisp/company/company-abbrev.el b/lisp/company/company-abbrev.el index 386feb64..42c80a94 100644 --- a/lisp/company/company-abbrev.el +++ b/lisp/company/company-abbrev.el @@ -1,6 +1,6 @@ ;;; company-abbrev.el --- company-mode completion backend for abbrev -;; Copyright (C) 2009-2011, 2015 Free Software Foundation, Inc. +;; Copyright (C) 2009-2011, 2015, 2021 Free Software Foundation, Inc. ;; Author: Nikolaj Schumacher @@ -44,7 +44,9 @@ (candidates (nconc (delete "" (all-completions arg global-abbrev-table)) (delete "" (all-completions arg local-abbrev-table)))) - (meta (abbrev-expansion arg)))) + (kind 'snippet) + (meta (abbrev-expansion arg)) + (post-completion (expand-abbrev)))) (provide 'company-abbrev) ;;; company-abbrev.el ends here diff --git a/lisp/company/company-capf.el b/lisp/company/company-capf.el index 7d34f9c5..5a2a2643 100644 --- a/lisp/company/company-capf.el +++ b/lisp/company/company-capf.el @@ -1,6 +1,6 @@ ;;; company-capf.el --- company-mode completion-at-point-functions backend -*- lexical-binding: t -*- -;; Copyright (C) 2013-2019 Free Software Foundation, Inc. +;; Copyright (C) 2013-2019, 2021 Free Software Foundation, Inc. ;; Author: Stefan Monnier @@ -148,8 +148,14 @@ so we can't just use the preceding variable instead.") :company-location))) (when f (funcall f arg)))) (`annotation + (company-capf--annotation arg)) + (`kind (let ((f (plist-get (nthcdr 4 company-capf--current-completion-data) - :annotation-function))) + :company-kind))) + (when f (funcall f arg)))) + (`deprecated + (let ((f (plist-get (nthcdr 4 company-capf--current-completion-data) + :company-deprecated))) (when f (funcall f arg)))) (`require-match (plist-get (nthcdr 4 (company--capf-data)) :company-require-match)) @@ -158,6 +164,17 @@ so we can't just use the preceding variable instead.") (company--capf-post-completion arg)) )) +(defun company-capf--annotation (arg) + (let* ((f (plist-get (nthcdr 4 company-capf--current-completion-data) + :annotation-function)) + (annotation (when f (funcall f arg)))) + (if (and company-format-margin-function + (equal annotation " ") ; elisp-completion-at-point, pre-icons + (plist-get (nthcdr 4 company-capf--current-completion-data) + :company-kind)) + nil + annotation))) + (defun company-capf--candidates (input) (let ((res (company--capf-data))) (company-capf--save-current-data res) diff --git a/lisp/company/company-clang.el b/lisp/company/company-clang.el index 24e59770..045a28e8 100644 --- a/lisp/company/company-clang.el +++ b/lisp/company/company-clang.el @@ -39,9 +39,10 @@ :type 'file) (defcustom company-clang-begin-after-member-access t - "When non-nil, automatic completion will start whenever the current -symbol is preceded by \".\", \"->\" or \"::\", ignoring -`company-minimum-prefix-length'. + "When non-nil, start automatic completion after member access operators. + +Automatic completion starts whenever the current symbol is preceded by +\".\", \"->\" or \"::\", ignoring `company-minimum-prefix-length'. If `company-begin-commands' is a list, it should include `c-electric-lt-gt' and `c-electric-colon', for automatic completion right after \">\" and @@ -59,7 +60,7 @@ it. That allows the flags use relative file names within the project." :safe 'booleanp) (defcustom company-clang-arguments nil - "Additional arguments to pass to clang when completing. + "A list of additional arguments to pass to clang when completing. Prefix files (-include ...) can be selected with `company-clang-set-prefix' or automatically through a custom `company-clang-prefix-guesser'." :type '(repeat (string :tag "Argument"))) @@ -230,6 +231,8 @@ or automatically through a custom `company-clang-prefix-guesser'." (let* ((objc (derived-mode-p 'objc-mode)) (buf (get-buffer-create "*clang-output*")) ;; Looks unnecessary in Emacs 25.1 and later. + ;; (Inconclusive, needs more testing): + ;; https://github.com/company-mode/company-mode/pull/288#issuecomment-72491808 (process-adaptive-read-buffering nil) (existing-process (get-buffer-process buf))) (when existing-process @@ -336,10 +339,9 @@ or automatically through a custom `company-clang-prefix-guesser'." (company-clang--check-version 2.9 3.1))) (defun company-clang--check-version (min apple-min) - (pcase company-clang--version + (pcase-exhaustive company-clang--version (`(apple . ,ver) (>= ver apple-min)) - (`(normal . ,ver) (>= ver min)) - (_ (error "pcase-exhaustive is not in Emacs 24.3!")))) + (`(normal . ,ver) (>= ver min)))) (defsubst company-clang-version () "Return the version of `company-clang-executable'." @@ -387,6 +389,7 @@ passed via standard input." (candidates (cons :async (lambda (cb) (company-clang--candidates arg cb)))) (meta (company-clang--meta arg)) + (kind (company-clang--kind arg)) (annotation (company-clang--annotation arg)) (post-completion (let ((anno (company-clang--annotation arg))) (when (and company-clang-insert-arguments anno) @@ -396,5 +399,22 @@ passed via standard input." (company-template-c-like-templatify (concat arg anno)))))))) +(defun company-clang--kind (arg) + ;; XXX: Not very precise. + ;; E.g. it will say that an arg-less ObjC method is a variable (perhaps we + ;; could look around for brackets, etc, if there any actual users who's + ;; bothered by it). + ;; And we can't distinguish between local vars and struct fields. + ;; Or between keywords and macros. + (let ((meta (company-clang--meta arg))) + (cond + ((null meta) 'keyword) + ((string-match "(" meta) + (if (string-match-p (format "\\`%s *\\'" (regexp-quote arg)) + (substring meta 0 (match-beginning 0))) + 'keyword ; Also macro, actually (no return type). + 'function)) + (t 'variable)))) + (provide 'company-clang) ;;; company-clang.el ends here diff --git a/lisp/company/company-dabbrev-code.el b/lisp/company/company-dabbrev-code.el index 6d250ce5..da62ab05 100644 --- a/lisp/company/company-dabbrev-code.el +++ b/lisp/company/company-dabbrev-code.el @@ -97,6 +97,7 @@ comments or strings." (`code company-dabbrev-code-modes) (`all `all)) (not company-dabbrev-code-everywhere)))) + (kind 'text) (ignore-case company-dabbrev-code-ignore-case) (duplicates t))) diff --git a/lisp/company/company-dabbrev.el b/lisp/company/company-dabbrev.el index 88b74198..c87aacfc 100644 --- a/lisp/company/company-dabbrev.el +++ b/lisp/company/company-dabbrev.el @@ -199,6 +199,7 @@ This variable affects both `company-dabbrev' and `company-dabbrev-code'." (if downcase-p (mapcar 'downcase words) words))) + (kind 'text) (ignore-case company-dabbrev-ignore-case) (duplicates t))) diff --git a/lisp/company/company-files.el b/lisp/company/company-files.el index 3d74c4de..69d67936 100644 --- a/lisp/company/company-files.el +++ b/lisp/company/company-files.el @@ -1,6 +1,6 @@ ;;; company-files.el --- company-mode completion backend for file names -;; Copyright (C) 2009-2011, 2014-2015 Free Software Foundation, Inc. +;; Copyright (C) 2009-2011, 2014-2021 Free Software Foundation, Inc. ;; Author: Nikolaj Schumacher @@ -33,11 +33,19 @@ :group 'company) (defcustom company-files-exclusions nil - "File name extensions and directory names to ignore. + "A list of file name extensions and directory names to ignore. The values should use the same format as `completion-ignored-extensions'." - :type '(const string) + :type '(repeat (string :tag "File extension or directory name")) :package-version '(company . "0.9.1")) +(defcustom company-files-chop-trailing-slash t + "Non-nil to remove the trailing slash after inserting directory name. + +This way it's easy to continue completion by typing `/' again. + +Set this to nil to disable that behavior." + :type 'boolean) + (defun company-files--directory-files (dir prefix) ;; Don't use directory-files. It produces directories without trailing /. (condition-case err @@ -51,7 +59,7 @@ The values should use the same format as `completion-ignored-extensions'." (file-error nil))) (defun company-files--exclusions-filtered (completions) - (let* ((dir-exclusions (cl-delete-if-not #'company-files--trailing-slash-p + (let* ((dir-exclusions (cl-remove-if-not #'company-files--trailing-slash-p company-files-exclusions)) (file-exclusions (cl-set-difference company-files-exclusions dir-exclusions))) @@ -128,7 +136,8 @@ The values should use the same format as `completion-ignored-extensions'." (string-prefix-p (car old) (car new)))) (defun company-files--post-completion (arg) - (when (company-files--trailing-slash-p arg) + (when (and company-files-chop-trailing-slash + (company-files--trailing-slash-p arg)) (delete-char -1))) ;;;###autoload @@ -144,6 +153,7 @@ File paths with spaces are only supported inside strings." (location (cons (dired-noselect (file-name-directory (directory-file-name arg))) 1)) (post-completion (company-files--post-completion arg)) + (kind (if (string-suffix-p "/" arg) 'folder 'file)) (sorted t) (no-cache t))) diff --git a/lisp/company/company-gtags.el b/lisp/company/company-gtags.el index 30b6f209..91b3121b 100644 --- a/lisp/company/company-gtags.el +++ b/lisp/company/company-gtags.el @@ -63,6 +63,11 @@ completion." (locate-dominating-file buffer-file-name "GTAGS")) company-gtags--tags-available-p)) +;; Avoid byte-compilation warnings on Emacs < 27. +(declare-function with-connection-local-variables "files-x") +(declare-function connection-local-set-profile-variables "files-x") +(declare-function connection-local-set-profiles "files-x") + (defun company-gtags--executable () (cond ((not (eq company-gtags--executable 'unknown)) ;; the value is already cached @@ -76,7 +81,8 @@ completion." company-gtags--executable-connection) ;; Else search and set as connection local for next uses. - (setq-local company-gtags--executable (executable-find "global" t)) + (setq-local company-gtags--executable + (with-no-warnings (executable-find "global" t))) (let* ((host (file-remote-p default-directory 'host)) (symvars (intern (concat host "-vars")))) ;; profile name @@ -94,7 +100,7 @@ completion." (let (tags) ;; For some reason Global v 6.6.3 is prone to returning exit status 1 ;; even on successful searches when '-T' is used. - (when (/= 3 (process-file company-gtags-executable nil + (when (/= 3 (process-file (company-gtags--executable) nil ;; "-T" goes through all the tag files listed in GTAGSLIBPATH (list (current-buffer) nil) nil "-xGqT" (concat "^" prefix))) (goto-char (point-min)) @@ -116,8 +122,17 @@ completion." (defun company-gtags--annotation (arg) (let ((meta (get-text-property 0 'meta arg))) - (when (string-match (concat (regexp-quote arg) "\\((.*)\\).*") meta) - (match-string 1 meta)))) + (when (string-match (concat (regexp-quote arg) " *(") meta) + (with-temp-buffer + (let ((start (match-end 0))) + (insert meta) + (goto-char start) + (condition-case nil + (forward-sexp) + (scan-error + (goto-char (point-max)))) + (buffer-substring-no-properties + start (point))))))) ;;;###autoload (defun company-gtags (command &optional arg &rest ignored) diff --git a/lisp/company/company-ispell.el b/lisp/company/company-ispell.el index 4d0bc229..7a460a83 100644 --- a/lisp/company/company-ispell.el +++ b/lisp/company/company-ispell.el @@ -75,6 +75,7 @@ If nil, use `ispell-complete-word-dict'." words ;; Work around issue #284. (all-completions arg words)))) + (kind 'text) (sorted t) (ignore-case 'keep-prefix))) diff --git a/lisp/company/company-keywords.el b/lisp/company/company-keywords.el index 80a0103e..cbe5094f 100644 --- a/lisp/company/company-keywords.el +++ b/lisp/company/company-keywords.el @@ -27,6 +27,15 @@ (require 'company) (require 'cl-lib) +(eval-when-compile (require 'make-mode)) + +(defgroup company-keywords nil + "Completion backend for keywords." + :group 'company) + +(defcustom company-keywords-ignore-case nil + "Non-nil to ignore case in completion candidates." + :type 'boolean) (defun company-keywords-upper-lower (&rest lst) ;; Upcase order is different for _. @@ -180,6 +189,10 @@ "internal" "is" "lateinit" "nested" "null" "object" "open" "out" "override" "package" "private" "protected" "public" "return" "super" "this" "throw" "trait" "true" "try" "typealias" "val" "var" "when" "while") + (lua-mode + ;; https://www.lua.org/manual/5.3/manual.html + "and" "break" "do" "else" "elseif" "end" "false" "for" "function" "goto" "if" + "in" "local" "nil" "not" "or" "repeat" "return" "then" "true" "until" "while") (objc-mode "@catch" "@class" "@encode" "@end" "@finally" "@implementation" "@interface" "@private" "@protected" "@protocol" "@public" @@ -293,6 +306,27 @@ (enh-ruby-mode . ruby-mode)) "Alist mapping major-modes to sorted keywords for `company-keywords'.") +(with-eval-after-load 'make-mode + (mapc + (lambda (mode-stmnts) + (setf (alist-get (car mode-stmnts) company-keywords-alist) + (cl-remove-duplicates + (sort (append makefile-special-targets-list + (cl-mapcan #'identity + (mapcar + #'split-string + (cl-remove-if-not + #'stringp + (symbol-value (cdr mode-stmnts)))))) + #'string<) + :test #'string=))) + '((makefile-automake-mode . makefile-automake-statements) + (makefile-gmake-mode . makefile-gmake-statements) + (makefile-makepp-mode . makefile-makepp-statements) + (makefile-bsdmake-mode . makefile-bsdmake-statements) + (makefile-imake-mode . makefile-statements) + (makefile-mode . makefile-statements)))) + ;;;###autoload (defun company-keywords (command &optional arg &rest ignored) "`company-mode' backend for programming language keywords." @@ -303,12 +337,14 @@ (not (company-in-string-or-comment)) (or (company-grab-symbol) 'stop))) (candidates - (let ((completion-ignore-case nil) + (let ((completion-ignore-case company-keywords-ignore-case) (symbols (cdr (assq major-mode company-keywords-alist)))) (all-completions arg (if (consp symbols) symbols (cdr (assq symbols company-keywords-alist)))))) - (sorted t))) + (kind 'keyword) + (sorted t) + (ignore-case company-keywords-ignore-case))) (provide 'company-keywords) ;;; company-keywords.el ends here diff --git a/lisp/company/company-pkg.el b/lisp/company/company-pkg.el index 1d72ca31..5bad067b 100644 --- a/lisp/company/company-pkg.el +++ b/lisp/company/company-pkg.el @@ -1,6 +1,6 @@ -(define-package "company" "20210103.1124" "Modular text completion framework" - '((emacs "24.3")) - :commit "6116c4617a7934acfe84cb82a058e9b198f0f480" :authors +(define-package "company" "20220103.351" "Modular text completion framework" + '((emacs "25.1")) + :commit "6eeaf46b869552b7cb70cab7d4590120c64cc175" :authors '(("Nikolaj Schumacher")) :maintainer '("Dmitry Gutov" . "dgutov@yandex.ru") diff --git a/lisp/company/company-tng.el b/lisp/company/company-tng.el index 3bfa2985..55124a30 100644 --- a/lisp/company/company-tng.el +++ b/lisp/company/company-tng.el @@ -1,6 +1,6 @@ ;;; company-tng.el --- company-mode configuration for single-button interaction -;; Copyright (C) 2017-2020 Free Software Foundation, Inc. +;; Copyright (C) 2017-2021 Free Software Foundation, Inc. ;; Author: Nikita Leshenko @@ -145,6 +145,17 @@ confirm the selection and finish the completion." (declare-function eglot--snippet-expansion-fn "eglot") +(defvar company-tng-map + (let ((keymap (make-sparse-keymap))) + (set-keymap-parent keymap company-active-map) + (define-key keymap [return] nil) + (define-key keymap (kbd "RET") nil) + (define-key keymap [tab] 'company-select-next) + (define-key keymap (kbd "TAB") 'company-select-next) + (define-key keymap [backtab] 'company-select-previous) + (define-key keymap (kbd "S-TAB") 'company-select-previous) + keymap)) + ;;;###autoload (define-minor-mode company-tng-mode "This minor mode enables `company-tng-frontend'." @@ -155,26 +166,30 @@ confirm the selection and finish the completion." (setq company-frontends (add-to-list 'company-frontends 'company-tng-frontend)) (when company-tng-auto-configure - (setq company-require-match nil) (setq company-frontends '(company-tng-frontend company-pseudo-tooltip-frontend company-echo-metadata-frontend)) - (setq company-clang-insert-arguments nil + (setq company-require-match nil + company-clang-insert-arguments nil company-semantic-insert-arguments nil company-rtags-insert-arguments nil lsp-enable-snippet nil) (advice-add #'eglot--snippet-expansion-fn :override #'ignore) - (let ((keymap company-active-map)) - (define-key keymap [return] nil) - (define-key keymap (kbd "RET") nil) - (define-key keymap [tab] 'company-select-next) - (define-key keymap (kbd "TAB") 'company-select-next) - (define-key keymap [backtab] 'company-select-previous) - (define-key keymap (kbd "S-TAB") 'company-select-previous))) + (setq company-active-map company-tng-map)) (setq company-selection-default nil)) (t (setq company-frontends - (delete 'company-tng-frontend company-frontends)) + '(company-pseudo-tooltip-unless-just-one-frontend + company-preview-if-just-one-frontend + company-echo-metadata-frontend)) + (when company-tng-auto-configure + (setq company-require-match 'company-explicit-action-p + company-clang-insert-arguments t + company-semantic-insert-arguments t + company-rtags-insert-arguments t + lsp-enable-snippet t) + (advice-remove #'eglot--snippet-expansion-fn #'ignore) + (setq company-active-map (keymap-parent company-tng-map))) (setq company-selection-default 0)))) (provide 'company-tng) diff --git a/lisp/company/company-yasnippet.el b/lisp/company/company-yasnippet.el index dfc959c6..e5df065a 100644 --- a/lisp/company/company-yasnippet.el +++ b/lisp/company/company-yasnippet.el @@ -35,6 +35,9 @@ (declare-function yas--template-expand-env "yasnippet") (declare-function yas--warning "yasnippet") (declare-function yas-minor-mode "yasnippet") +(declare-function yas--require-template-specific-condition-p "yasnippet") +(declare-function yas--template-can-expand-p "yasnippet") +(declare-function yas--template-condition "yasnippet") (defvar company-yasnippet-annotation-fn (lambda (name) @@ -86,6 +89,7 @@ It has to accept one argument: the snippet's name.") (cl-mapcan (lambda (table) (let ((keyhash (yas--table-hash table)) + (requirement (yas--require-template-specific-condition-p)) res) (when keyhash (maphash @@ -94,13 +98,15 @@ It has to accept one argument: the snippet's name.") (string-prefix-p key-prefix key)) (maphash (lambda (name template) - (push - (propertize key - 'yas-annotation name - 'yas-template template - 'yas-prefix-offset (- (length key-prefix) - (length prefix))) - res)) + (when (yas--template-can-expand-p + (yas--template-condition template) requirement) + (push + (propertize key + 'yas-annotation name + 'yas-template template + 'yas-prefix-offset (- (length key-prefix) + (length prefix))) + res))) value))) keyhash)) res)) @@ -165,6 +171,7 @@ shadow backends that come after it. Recommended usages: (candidates (company-yasnippet--candidates arg)) (doc-buffer (company-yasnippet--doc arg)) (no-cache t) + (kind 'snippet) (post-completion (let ((template (get-text-property 0 'yas-template arg)) (prefix-offset (get-text-property 0 'yas-prefix-offset arg))) diff --git a/lisp/company/company.el b/lisp/company/company.el index c20475e5..5a207dfe 100644 --- a/lisp/company/company.el +++ b/lisp/company/company.el @@ -1,13 +1,13 @@ ;;; company.el --- Modular text completion framework -*- lexical-binding: t -*- -;; Copyright (C) 2009-2020 Free Software Foundation, Inc. +;; Copyright (C) 2009-2021 Free Software Foundation, Inc. ;; Author: Nikolaj Schumacher ;; Maintainer: Dmitry Gutov ;; URL: http://company-mode.github.io/ ;; Version: 0.9.13 ;; Keywords: abbrev, convenience, matching -;; Package-Requires: ((emacs "24.3")) +;; Package-Requires: ((emacs "25.1")) ;; This file is part of GNU Emacs. @@ -62,27 +62,15 @@ ;;; Code: (require 'cl-lib) -(require 'newcomment) +(require 'subr-x) (require 'pcase) -;;; Compatibility -(eval-and-compile - ;; Defined in Emacs 24.4 - (unless (fboundp 'string-suffix-p) - (defun string-suffix-p (suffix string &optional ignore-case) - "Return non-nil if SUFFIX is a suffix of STRING. -If IGNORE-CASE is non-nil, the comparison is done without paying -attention to case differences." - (let ((start-pos (- (length string) (length suffix)))) - (and (>= start-pos 0) - (eq t (compare-strings suffix nil nil - string start-pos nil ignore-case))))))) - (defgroup company nil "Extensible inline text completion mechanism." :group 'abbrev :group 'convenience - :group 'matching) + :group 'matching + :link '(custom-manual "(company) Top")) (defgroup company-faces nil "Faces used by Company." @@ -90,23 +78,25 @@ attention to case differences." :group 'faces) (defface company-tooltip - '((default :foreground "black") - (((class color) (min-colors 88) (background light)) - (:background "cornsilk")) + '((((class color) (min-colors 88) (background light)) + (:foreground "black" :background "cornsilk")) (((class color) (min-colors 88) (background dark)) - (:background "yellow")) - (t - (:background "yellow"))) + (:background "gray26")) + (t (:foreground "black" :background "yellow"))) "Face used for the tooltip.") (defface company-tooltip-selection '((((class color) (min-colors 88) (background light)) (:background "light blue")) (((class color) (min-colors 88) (background dark)) - (:background "orange1")) + (:background "gray31")) (t (:background "green"))) "Face used for the selection in the tooltip.") +(defface company-tooltip-deprecated + '((t (:strike-through t))) + "Face used for the deprecated items.") + (defface company-tooltip-search '((default :inherit highlight)) "Face used for the search string in the tooltip.") @@ -123,7 +113,7 @@ attention to case differences." '((((background light)) :foreground "darkred") (((background dark)) - :foreground "red")) + :foreground "pale turquoise")) "Face used for the common completion in the tooltip.") (defface company-tooltip-common-selection @@ -134,57 +124,65 @@ attention to case differences." '((((background light)) :foreground "firebrick4") (((background dark)) - :foreground "red4")) + :foreground "LightCyan3")) "Face used for the completion annotation in the tooltip.") (defface company-tooltip-annotation-selection '((default :inherit company-tooltip-annotation)) "Face used for the selected completion annotation in the tooltip.") -(defface company-scrollbar-fg +(defface company-tooltip-quick-access + '((default :inherit company-tooltip-annotation)) + "Face used for the quick-access hints shown in the tooltip." + :package-version '(company . "0.9.14")) + +(defface company-tooltip-quick-access-selection + '((default :inherit company-tooltip-annotation-selection)) + "Face used for the selected quick-access hints shown in the tooltip." + :package-version '(company . "0.9.14")) + +(define-obsolete-face-alias + 'company-scrollbar-fg + 'company-tooltip-scrollbar-thumb + "0.9.14") + +(defface company-tooltip-scrollbar-thumb '((((background light)) :background "darkred") (((background dark)) - :background "red")) - "Face used for the tooltip scrollbar thumb.") + :background "gray33")) + "Face used for the tooltip scrollbar thumb (bar).") -(defface company-scrollbar-bg +(define-obsolete-face-alias + 'company-scrollbar-bg + 'company-tooltip-scrollbar-track + "0.9.14") + +(defface company-tooltip-scrollbar-track '((((background light)) :background "wheat") (((background dark)) - :background "gold")) - "Face used for the tooltip scrollbar background.") + :background "gray28")) + "Face used for the tooltip scrollbar track (trough).") (defface company-preview - '((((background light)) - :inherit (company-tooltip-selection company-tooltip)) - (((background dark)) - :background "blue4" - :foreground "wheat")) + '((default :inherit (company-tooltip-selection company-tooltip))) "Face used for the completion preview.") (defface company-preview-common - '((((background light)) - :inherit company-tooltip-common-selection) - (((background dark)) - :inherit company-preview - :foreground "red")) + '((default :inherit company-tooltip-common-selection)) "Face used for the common part of the completion preview.") (defface company-preview-search - '((((background light)) - :inherit company-tooltip-common-selection) - (((background dark)) - :inherit company-preview - :background "blue1")) + '((default :inherit company-tooltip-common-selection)) "Face used for the search string in the completion preview.") (defface company-echo nil "Face used for completions in the echo area.") (defface company-echo-common - '((((background dark)) (:foreground "firebrick1")) - (((background light)) (:background "firebrick4"))) + '((((background light)) (:foreground "firebrick4")) + (((background dark)) (:foreground "firebrick1"))) "Face used for the common part of completions in the echo area.") ;; Too lazy to re-add :group to all defcustoms down below. @@ -237,6 +235,10 @@ visualization is active. `post-command': After every command that is executed while the visualization is active. +`unhide': When an asynchronous backend is waiting for its completions. +Only needed in frontends which hide their visualizations in `pre-command' +for technical reasons. + The visualized data is stored in `company-prefix', `company-candidates', `company-common', `company-selection', `company-point' and `company-search-string'." @@ -264,8 +266,9 @@ The visualized data is stored in `company-prefix', `company-candidates', :type 'integer) (defcustom company-tooltip-minimum 6 - "The minimum height of the tooltip. -If this many lines are not available, prefer to display the tooltip above." + "Ensure visibility of this number of candidates. +When that many lines are not available between point and the bottom of the +window, display the tooltip above point." :type 'integer) (defcustom company-tooltip-minimum-width 0 @@ -335,9 +338,7 @@ This doesn't include the margins and the scroll bar." (assq backend company-safe-backends)) (cl-return t)))))) -(defcustom company-backends `(,@(unless (version< "24.3.51" emacs-version) - (list 'company-elisp)) - company-bbdb +(defcustom company-backends `(company-bbdb ,@(unless (version<= "26" emacs-version) (list 'company-nxml)) ,@(unless (version<= "26" emacs-version) @@ -418,6 +419,9 @@ be kept if they have different annotations. For that to work properly, backends should store the related information on candidates using text properties. +`deprecated': The second argument is a completion candidate. Return +non-nil if the completion candidate is deprecated. + `match': The second argument is a completion candidate. Return a positive integer, the index after the end of text matching `prefix' within the candidate string. Alternatively, return a list of (CHUNK-START @@ -442,6 +446,10 @@ completion. into the buffer. The second argument is the candidate. Can be used to modify it, e.g. to expand a snippet. +`kind': The second argument is a completion candidate. Return a symbol +describing the kind of the candidate. Refer to `company-vscode-icons-mapping' +for the possible values. + The backend should return nil for all commands it does not support or does not know about. It should also be callable interactively and use `company-begin-backend' to start itself in that case. @@ -616,7 +624,7 @@ A character that is part of a valid completion never triggers auto-commit." (function :tag "Predicate function")) :package-version '(company . "0.9.14")) -(defcustom company-idle-delay .5 +(defcustom company-idle-delay .2 "The idle delay in seconds until completion starts automatically. The prefix still has to satisfy `company-minimum-prefix-length' before that happens. The value of nil means no idle completion." @@ -666,24 +674,139 @@ commands in the `company-' namespace, abort completion." (repeat :tag "Commands" function)) (repeat :tag "Commands" function))) -(defcustom company-show-numbers nil - "If enabled, show quick-access numbers for the first ten candidates." - :type '(choice (const :tag "off" nil) - (const :tag "left" 'left) - (const :tag "on" 't))) +(defun company-custom--set-quick-access (option value) + "Re-bind quick-access key sequences on OPTION VALUE change." + (when (boundp 'company-active-map) + (company-keymap--unbind-quick-access company-active-map)) + (when (boundp 'company-search-map) + (company-keymap--unbind-quick-access company-search-map)) + (custom-set-default option value) + (when (boundp 'company-active-map) + (company-keymap--bind-quick-access company-active-map)) + (when (boundp 'company-search-map) + (company-keymap--bind-quick-access company-search-map))) -(defcustom company-show-numbers-function #'company--show-numbers +(defcustom company-quick-access-keys '("1" "2" "3" "4" "5" "6" "7" "8" "9" "0") + "Character strings used as a part of quick-access key sequences. +To change this value without Customize interface, use `customize-set-variable'. + +To change the quick-access key sequences modifier, customize +`company-quick-access-modifier'. + +If `company-show-quick-access' is non-nil, show quick-access hints +beside the candidates." + :set #'company-custom--set-quick-access + :type '(choice + (const :tag "Digits" ("1" "2" "3" "4" "5" "6" "7" "8" "9" "0")) + (const :tag "QWERTY home row" ("a" "s" "d" "f" "g" "h" "j" "k" "l" ";")) + ;; TODO un-comment on removal of `M-n' `company--select-next-and-warn'. + ;; (const :tag "Dvorak home row" ("a" "o" "e" "u" "i" "d" "h" "t" "n" "s")) + (repeat :tag "User defined" string)) + :package-version '(company . "0.9.14")) + +(defcustom company-quick-access-modifier 'meta + "Modifier key used for quick-access keys sequences. +To change this value without Customize interface, use `customize-set-variable'. +See `company-quick-access-keys' for more details." + :set #'company-custom--set-quick-access + :type '(choice (const :tag "Meta key" meta) + (const :tag "Super key" super) + (const :tag "Hyper key" hyper) + (const :tag "Control key" control)) + :package-version '(company . "0.9.14")) + +(defun company-keymap--quick-access-modifier () + "Return string representation of the `company-quick-access-modifier'." + (if-let ((modifier (assoc-default company-quick-access-modifier + '((meta . "M") + (super . "s") + (hyper . "H") + (control . "C"))))) + modifier + (warn "company-quick-access-modifier value unknown: %S" + company-quick-access-modifier) + "M")) + +(defun company-keymap--unbind-quick-access (keymap) + (let ((modifier (company-keymap--quick-access-modifier))) + (dolist (key company-quick-access-keys) + (let ((key-seq (company-keymap--kbd-quick-access modifier key))) + (when (equal (lookup-key keymap key-seq) 'company-complete-quick-access) + (define-key keymap key-seq nil)))))) + +(defun company-keymap--bind-quick-access (keymap) + (let ((modifier (company-keymap--quick-access-modifier))) + (dolist (key company-quick-access-keys) + (let ((key-seq (company-keymap--kbd-quick-access modifier key))) + (if (lookup-key keymap key-seq) + (warn "Key sequence %s already bound" (key-description key-seq)) + (define-key keymap key-seq #'company-complete-quick-access)))))) + +(defun company-keymap--kbd-quick-access (modifier key) + (kbd (format "%s-%s" modifier key))) + +(define-obsolete-variable-alias + 'company-show-numbers + 'company-show-quick-access + "0.9.14") + +(defcustom company-show-quick-access nil + "If non-nil, show quick-access hints beside the candidates. + +For a tooltip frontend, non-nil value enables a column with the hints +on the right side of the tooltip, unless the configured value is `left'. + +To change the quick-access key bindings, customize `company-quick-access-keys' +and `company-quick-access-modifier'. + +To change the shown quick-access hints, customize +`company-quick-access-hint-function'." + :type '(choice (const :tag "off" nil) + (const :tag "left" left) + (const :tag "on" t))) + +(defcustom company-show-numbers-function nil "Function called to get quick-access numbers for the first ten candidates. The function receives the candidate number (starting from 1) and should return a string prefixed with one space." :type 'function) +(make-obsolete-variable + 'company-show-numbers-function + "use `company-quick-access-hint-function' instead, +but adjust the expected values appropriately." + "0.9.14") + +(defcustom company-quick-access-hint-function #'company-quick-access-hint-key + "Function called to get quick-access hints for the candidates. + +The function receives a candidate's 0-based number +and should return a string. +See `company-show-quick-access' for more details." + :type 'function) + +(defun company-quick-access-hint-key (candidate) + "Return a quick-access key for the CANDIDATE number. +This is a default value of `company-quick-access-hint-function'." + (if company-show-numbers-function + (funcall company-show-numbers-function (1+ candidate)) + (format "%s" + (if (< candidate (length company-quick-access-keys)) + (nth candidate company-quick-access-keys) + "")))) (defcustom company-selection-wrap-around nil "If enabled, selecting item before first or after last wraps around." :type '(choice (const :tag "off" nil) (const :tag "on" t))) +(defcustom company-async-redisplay-delay 0.005 + "Delay before redisplay when fetching candidates asynchronously. + +You might want to set this to a higher value if your backends respond +quickly, to avoid redisplaying twice per each typed character." + :type 'number) + (defvar company-async-wait 0.03 "Pause between checks to see if the value's been set when turning an asynchronous call into synchronous.") @@ -700,8 +823,10 @@ asynchronous call into synchronous.") (let ((keymap (make-sparse-keymap))) (define-key keymap "\e\e\e" 'company-abort) (define-key keymap "\C-g" 'company-abort) - (define-key keymap (kbd "M-n") 'company-select-next) - (define-key keymap (kbd "M-p") 'company-select-previous) + (define-key keymap (kbd "M-n") 'company--select-next-and-warn) + (define-key keymap (kbd "M-p") 'company--select-previous-and-warn) + (define-key keymap (kbd "C-n") 'company-select-next-or-abort) + (define-key keymap (kbd "C-p") 'company-select-previous-or-abort) (define-key keymap (kbd "") 'company-select-next-or-abort) (define-key keymap (kbd "") 'company-select-previous-or-abort) (define-key keymap [remap scroll-up-command] 'company-next-page) @@ -721,13 +846,29 @@ asynchronous call into synchronous.") (define-key keymap "\C-w" 'company-show-location) (define-key keymap "\C-s" 'company-search-candidates) (define-key keymap "\C-\M-s" 'company-filter-candidates) - (dotimes (i 10) - (define-key keymap (read-kbd-macro (format "M-%d" i)) 'company-complete-number)) + (company-keymap--bind-quick-access keymap) keymap) "Keymap that is enabled during an active completion.") (defvar company--disabled-backends nil) +(defun company--select-next-and-warn (&optional arg) + (interactive "p") + (company--warn-changed-binding) + (company-select-next arg)) + +(defun company--select-previous-and-warn (&optional arg) + (interactive "p") + (company--warn-changed-binding) + (company-select-previous arg)) + +(defun company--warn-changed-binding () + (interactive) + (run-with-idle-timer + 0.01 nil + (lambda () + (message "Warning: default bindings are being changed to C-n and C-p")))) + (defun company-init-backend (backend) (and (symbolp backend) (not (fboundp backend)) @@ -808,7 +949,7 @@ regular keymap (`company-mode-map'): keymap during active completions (`company-active-map'): \\{company-active-map}" - nil company-lighter company-mode-map + :lighter company-lighter (if company-mode (progn (add-hook 'pre-command-hook 'company-pre-command nil t) @@ -884,20 +1025,6 @@ means that `company-mode' is always turned on except in `message-mode' buffers." (or (equal [company-dummy-event] keys) (commandp (lookup-key company-my-keymap keys)))) -;; Hack: -;; Emacs calculates the active keymaps before reading the event. That means we -;; cannot change the keymap from a timer. So we send a bogus command. -;; XXX: Seems not to be needed anymore in Emacs 24.4 -;; Apparently, starting with emacs-mirror/emacs@99d0d6dc23. -(defun company-ignore () - (interactive) - (setq this-command last-command)) - -(global-set-key '[company-dummy-event] 'company-ignore) - -(defun company-input-noop () - (push 'company-dummy-event unread-command-events)) - ;; To avoid warnings in Emacs < 26. (declare-function line-number-display-width "indent.c") @@ -908,9 +1035,6 @@ means that `company-mode' is always turned on except in `message-mode' buffers." (row (cdr (or (posn-actual-col-row posn) ;; When position is non-visible for some reason. (posn-col-row posn))))) - (when (and header-line-format (version< emacs-version "24.3.93.3")) - ;; http://debbugs.gnu.org/18384 - (cl-decf row)) (when (bound-and-true-p display-line-numbers) (cl-decf col (+ 2 (line-number-display-width)))) (cons (+ col (window-hscroll)) row))) @@ -1033,6 +1157,9 @@ matches IDLE-BEGIN-AFTER-RE, return it wrapped in a cons." (cl-dolist (backend backends) (when (setq value (company--force-sync backend (cons command args) backend)) + (when (and (eq command 'ignore-case) + (eq value 'keep-prefix)) + (setq value t)) (cl-return value))))) (_ (let ((arg (car args))) @@ -1281,10 +1408,13 @@ update if FORCE-UPDATE." company-candidates-cache))) (setq candidates (all-completions prefix prev)) (cl-return t))))) - (progn - ;; No cache match, call the backend. + ;; No cache match, call the backend. + (let ((refresh-timer (run-with-timer company-async-redisplay-delay + nil #'company--sneaky-refresh))) (setq candidates (company--preprocess-candidates (company--fetch-candidates prefix))) + ;; If the backend is synchronous, no chance for the timer to run. + (cancel-timer refresh-timer) ;; Save in cache. (push (cons prefix candidates) company-candidates-cache))) ;; Only now apply the predicate and transformers. @@ -1327,6 +1457,12 @@ update if FORCE-UPDATE." (and (consp res) res) (setq res 'exited)))))) +(defun company--sneaky-refresh () + (when company-candidates (company-call-frontends 'unhide)) + (let (inhibit-redisplay) + (redisplay)) + (when company-candidates (company-call-frontends 'pre-command))) + (defun company--flyspell-workaround-p () ;; https://debbugs.gnu.org/23980 (and (bound-and-true-p flyspell-mode) @@ -1349,23 +1485,27 @@ update if FORCE-UPDATE." (defun company--strip-duplicates (candidates) (let ((c2 candidates) - (annos 'unk)) + (extras 'unk)) (while c2 (setcdr c2 (let ((str (pop c2))) (while (let ((str2 (car c2))) (if (not (equal str str2)) (progn - (setq annos 'unk) + (setq extras 'unk) nil) - (when (eq annos 'unk) - (setq annos (list (company-call-backend - 'annotation str)))) - (let ((anno2 (company-call-backend - 'annotation str2))) - (if (member anno2 annos) + (when (eq extras 'unk) + (setq extras (list (cons (company-call-backend + 'annotation str) + (company-call-backend + 'kind str))))) + (let ((extra2 (cons (company-call-backend + 'annotation str2) + (company-call-backend + 'kind str2)))) + (if (member extra2 extras) t - (push anno2 annos) + (push extra2 extras) nil)))) (pop c2)) c2))))) @@ -1387,6 +1527,270 @@ end of the match." (const :tag "Prefer closest in any direction" company-occurrence-prefer-any-closest))) +(defvar company-vscode-icons-mapping + '((array . "symbol-array.svg") + (boolean . "symbol-boolean.svg") + (class . "symbol-class.svg") + (color . "symbol-color.svg") + (constant . "symbol-constant.svg") + (constructor . "symbol-method.svg") + (enum-member . "symbol-enumerator-member.svg") + (enum . "symbol-enumerator.svg") + (event . "symbol-event.svg") + (field . "symbol-field.svg") + (file . "symbol-file.svg") + (folder . "folder.svg") + (interface . "symbol-interface.svg") + (keyword . "symbol-keyword.svg") + (method . "symbol-method.svg") + (function . "symbol-method.svg") + (module . "symbol-namespace.svg") + (numeric . "symbol-numeric.svg") + (operator . "symbol-operator.svg") + (property . "symbol-property.svg") + (reference . "references.svg") + (snippet . "symbol-snippet.svg") + (string . "symbol-string.svg") + (struct . "symbol-structure.svg") + (text . "symbol-key.svg") + (type-parameter . "symbol-parameter.svg") + (unit . "symbol-ruler.svg") + (value . "symbol-enumerator.svg") + (variable . "symbol-variable.svg") + (t . "symbol-misc.svg"))) + +(defconst company-icons-root + (file-name-as-directory + (expand-file-name "icons" + (file-name-directory (or load-file-name buffer-file-name))))) + +(defcustom company-icon-size '(auto-scale . 16) + "Size of icons indicating completion kind in the popup." + :type '(choice (integer :tag "Size in pixels" :value 16) + (cons :tag "Size in pixels, scaled 2x on HiDPI screens" + (const auto-scale) + (integer :value 16)))) + +(defcustom company-icon-margin 2 + "Width of the margin that shows the icons, in characters." + :type 'integer) + +(defun company--render-icons-margin (icon-mapping root-dir candidate selected) + (if-let ((ws (window-system)) + (candidate candidate) + (kind (company-call-backend 'kind candidate)) + (icon-file (or (alist-get kind icon-mapping) + (alist-get t icon-mapping)))) + (let* ((bkg (face-attribute (if selected + 'company-tooltip-selection + 'company-tooltip) + :background)) + (dfw (default-font-width)) + (icon-size (cond + ((integerp company-icon-size) + company-icon-size) + ;; XXX: Also consider smooth scaling, e.g. using + ;; (aref (font-info (face-font 'default)) 2) + ((and (consp company-icon-size) + (eq 'auto-scale (car company-icon-size))) + (let ((base-size (cdr company-icon-size)) + (dfh (default-font-height))) + (min + (if (> dfh (* 2 base-size)) + (* 2 base-size) + base-size) + (* company-icon-margin dfw)))))) + (spec (list 'image + :file (expand-file-name icon-file root-dir) + :type 'svg + :width icon-size + :height icon-size + :ascent 'center + :background (unless (eq bkg 'unspecified) + bkg))) + (spacer-px-width (- (* company-icon-margin dfw) icon-size))) + (concat + (propertize " " 'display spec) + (propertize (company-space-string (1- company-icon-margin)) + 'display `(space . (:width (,spacer-px-width)))))) + nil)) + +(defun company-vscode-dark-icons-margin (candidate selected) + "Margin function which returns icons from vscode's dark theme." + (company--render-icons-margin company-vscode-icons-mapping + (expand-file-name "vscode-dark" company-icons-root) + candidate + selected)) + +(defun company-vscode-light-icons-margin (candidate selected) + "Margin function which returns icons from vscode's light theme." + (company--render-icons-margin company-vscode-icons-mapping + (expand-file-name "vscode-light" company-icons-root) + candidate + selected)) + +(defcustom company-text-icons-mapping + '((array "a" font-lock-type-face) + (boolean "b" font-lock-builtin-face) + (class "c" font-lock-type-face) + (color "#" success) + (constant "c" font-lock-constant-face) + (constructor "c" font-lock-function-name-face) + (enum-member "e" font-lock-builtin-face) + (enum "e" font-lock-builtin-face) + (field "f" font-lock-variable-name-face) + (file "f" font-lock-string-face) + (folder "d" font-lock-doc-face) + (interface "i" font-lock-type-face) + (keyword "k" font-lock-keyword-face) + (method "m" font-lock-function-name-face) + (function "f" font-lock-function-name-face) + (module "{" font-lock-type-face) + (numeric "n" font-lock-builtin-face) + (operator "o" font-lock-comment-delimiter-face) + (property "p" font-lock-variable-name-face) + (reference "r" font-lock-doc-face) + (snippet "S" font-lock-string-face) + (string "s" font-lock-string-face) + (struct "%" font-lock-variable-name-face) + (text "w" shadow) + (type-parameter "p" font-lock-type-face) + (unit "u" shadow) + (value "v" font-lock-builtin-face) + (variable "v" font-lock-variable-name-face) + (t "." shadow)) + "Mapping of the text icons. +The format should be an alist of (KIND . CONF) where CONF is a list of the +form (ICON FG BG) which is used to propertize the icon to be shown for a +candidate of kind KIND. FG can either be color string or a face from which +we can get a color string (using the :foreground face-property). BG must be +of the same form as FG or a cons cell of (BG . BG-WHEN-SELECTED) which each +should be of the same form as FG. + +The only mandatory element in CONF is ICON, you can omit both the FG and BG +fields without issue. + +When BG is omitted and `company-text-icons-add-background' is non-nil, a BG +color is generated using a gradient between the active tooltip color and +the FG color." + :type 'list) + +(defcustom company-text-face-extra-attributes '(:weight bold) + "Additional attributes to add to text/dot icons faces. +If non-nil, an anonymous face is generated. + +Affects `company-text-icons-margin' and `company-dot-icons-margin'." + :type 'list) + +(defcustom company-text-icons-format " %s " + "Format string for printing the text icons." + :type 'string) + +(defcustom company-text-icons-add-background nil + "Generate a background color for text/dot icons when none is given. +See `company-text-icons-mapping'." + :type 'boolean) + +(defun company-text-icons-margin (candidate selected) + "Margin function which returns unicode icons." + (when-let ((candidate candidate) + (kind (company-call-backend 'kind candidate)) + (conf (or (alist-get kind company-text-icons-mapping) + (alist-get t company-text-icons-mapping)))) + (cl-destructuring-bind (icon &optional fg bg) conf + (propertize + (format company-text-icons-format icon) + 'face + (company-text-icons--face fg bg selected))))) + +(declare-function color-rgb-to-hex "color") +(declare-function color-gradient "color") + +(defun company-text-icons--extract-property (face property) + "Try to extract PROPERTY from FACE. +If FACE isn't a valid face return FACE as is. If FACE doesn't have +PROPERTY return nil." + (if (facep face) + (let ((value (face-attribute face property))) + (unless (eq value 'unspecified) + value)) + face)) + +(defun company-text-icons--face (fg bg selected) + (let ((fg-color (company-text-icons--extract-property fg :foreground))) + `(,@company-text-face-extra-attributes + ,@(and fg-color + (list :foreground fg-color)) + ,@(let* ((bg-is-cons (consp bg)) + (bg (if bg-is-cons (if selected (cdr bg) (car bg)) bg)) + (bg-color (company-text-icons--extract-property bg :background)) + (tooltip-bg-color (company-text-icons--extract-property + (if selected + 'company-tooltip-selection + 'company-tooltip) + :background))) + (cond + ((and company-text-icons-add-background selected + (not bg-is-cons) bg-color tooltip-bg-color) + ;; Adjust the coloring of the background when *selected* but user hasn't + ;; specified an alternate background color for selected item icons. + (list :background + (apply #'color-rgb-to-hex + (nth 0 (color-gradient (color-name-to-rgb tooltip-bg-color) + (color-name-to-rgb bg-color) + 2))))) + (bg + ;; When background is configured we use it as is, even if it doesn't + ;; constrast well with other candidates when selected. + (and bg-color + (list :background bg-color))) + ((and company-text-icons-add-background fg-color tooltip-bg-color) + ;; Lastly attempt to generate a background from the foreground. + (list :background + (apply #'color-rgb-to-hex + (nth 0 (color-gradient (color-name-to-rgb tooltip-bg-color) + (color-name-to-rgb fg-color) + 10)))))))))) + +(defcustom company-dot-icons-format "● " + "Format string for `company-dot-icons-margin'." + :type 'string) + +(defun company-dot-icons-margin (candidate selected) + "Margin function that uses a colored dot to display completion kind." + (when-let ((kind (company-call-backend 'kind candidate)) + (conf (or (assoc-default kind company-text-icons-mapping) + (assoc-default t company-text-icons-mapping)))) + (cl-destructuring-bind (_icon &optional fg bg) conf + (propertize company-dot-icons-format + 'face + (company-text-icons--face fg bg selected))))) + +(defun company-detect-icons-margin (candidate selected) + "Margin function which picks the appropriate icon set automatically." + (if (and (display-graphic-p) + (image-type-available-p 'svg)) + (cl-case (frame-parameter nil 'background-mode) + ('light (company-vscode-light-icons-margin candidate selected)) + (t (company-vscode-dark-icons-margin candidate selected))) + (company-text-icons-margin candidate selected))) + +(defcustom company-format-margin-function #'company-detect-icons-margin + "Function to format the margin. +It accepts 2 params `candidate' and `selected' and can be used for +inserting prefix/image before the completion items. Typically, the +functions call the backends with `kind' and then insert the appropriate +image for the returned kind image. Function is called with (nil nil) to get +the default margin." + :type '(choice + (const :tag "Disabled" nil) + (const :tag "Detect icons theme base on conditions" company-detect-icons-margin) + (const :tag "Text characters as icons" company-text-icons-margin) + (const :tag "Colored dots as icons" company-dot-icons-margin) + (const :tag "VScode dark icons theme" company-vscode-dark-icons-margin) + (const :tag "VScode light icons theme" company-vscode-light-icons-margin) + (function :tag "Custom icon function."))) + (defun company-occurrence-prefer-closest-above (pos match-beg match-end) "Give priority to the matches above point, then those below point." (if (< match-beg pos) @@ -1411,13 +1815,22 @@ Keywords and function definition names are ignored." (save-excursion (cl-delete-if (lambda (candidate) - (when (catch 'done - (goto-char w-start) - (while (search-forward candidate w-end t) - (when (and (not (eq (point) start-point)) - (save-match-data - (company--occurrence-predicate))) - (throw 'done t)))) + (goto-char w-start) + (when (and (not (equal candidate "")) + (search-forward candidate w-end t) + ;; ^^^ optimize for large lists where most elements + ;; won't have a match. + (catch 'done + (goto-char (1- start-point)) + (while (search-backward candidate w-start t) + (when (save-match-data + (company--occurrence-predicate)) + (throw 'done t))) + (goto-char start-point) + (while (search-forward candidate w-end t) + (when (save-match-data + (company--occurrence-predicate)) + (throw 'done t))))) (push (cons candidate (funcall company-occurrence-weight-function @@ -1485,11 +1898,10 @@ prefix match (same case) will be prioritized." (eq win (selected-window)) (eq tick (buffer-chars-modified-tick)) (eq pos (point)) - (when (company-auto-begin) - (when (version< emacs-version "24.3.50") - (company-input-noop)) - (let ((this-command 'company-idle-begin)) - (company-post-command))))) + (let ((non-essential t)) + (when (company-auto-begin) + (let ((this-command 'company-idle-begin)) + (company-post-command)))))) (defun company-auto-begin () (and company-mode @@ -1791,7 +2203,7 @@ prefix match (same case) will be prioritized." company-complete company-complete-common company-complete-selection - company-complete-number) + company-complete-tooltip-row) "List of commands after which idle completion is (still) disabled when `company-begin-commands' is t.") @@ -1868,20 +2280,22 @@ each one wraps a part of the input string." (let ((re (funcall company-search-regexp-function text)) (i 0)) (cl-dolist (line lines) - (when (string-match-p re line (length company-prefix)) + (when (string-match-p re line) (cl-return i)) (cl-incf i)))) -(defun company-search-keypad () - (interactive) - (let* ((name (symbol-name last-command-event)) - (last-command-event (aref name (1- (length name))))) - (company-search-printing-char))) - (defun company-search-printing-char () (interactive) (company--search-assert-enabled) - (let ((ss (concat company-search-string (string last-command-event)))) + (let* ((event-type (event-basic-type last-command-event)) + (event-string (if (characterp event-type) + (string last-command-event) + ;; Handle key press on the keypad. + (let ((name (symbol-name event-type))) + (if (string-match "kp-\\([0-9]\\)" name) + (match-string 1 name) + (error "Unexpected printing char input"))))) + (ss (concat company-search-string event-string))) (when company-search-filtering (company--search-update-predicate ss)) (company--search-update-string ss))) @@ -1988,13 +2402,15 @@ each one wraps a part of the input string." (define-key keymap (vector i) 'company-search-printing-char) (cl-incf i)) (dotimes (i 10) - (define-key keymap (read (format "[kp-%s]" i)) 'company-search-keypad)) + (define-key keymap (kbd (format "" i)) 'company-search-printing-char)) (let ((meta-map (make-sparse-keymap))) (define-key keymap (char-to-string meta-prefix-char) meta-map) (define-key keymap [escape] meta-map)) (define-key keymap (vector meta-prefix-char t) 'company-search-other-char) - (define-key keymap (kbd "M-n") 'company-select-next) - (define-key keymap (kbd "M-p") 'company-select-previous) + (define-key keymap (kbd "C-n") 'company-select-next-or-abort) + (define-key keymap (kbd "C-p") 'company-select-previous-or-abort) + (define-key keymap (kbd "M-n") 'company--select-next-and-warn) + (define-key keymap (kbd "M-p") 'company--select-previous-and-warn) (define-key keymap (kbd "") 'company-select-next-or-abort) (define-key keymap (kbd "") 'company-select-previous-or-abort) (define-key keymap "\e\e\e" 'company-search-other-char) @@ -2005,8 +2421,7 @@ each one wraps a part of the input string." (define-key keymap "\C-s" 'company-search-repeat-forward) (define-key keymap "\C-r" 'company-search-repeat-backward) (define-key keymap "\C-o" 'company-search-toggle-filtering) - (dotimes (i 10) - (define-key keymap (read-kbd-macro (format "M-%d" i)) 'company-complete-number)) + (company-keymap--bind-quick-access keymap) keymap) "Keymap used for incrementally searching the completion candidates.") @@ -2014,7 +2429,7 @@ each one wraps a part of the input string." "Search mode for completion candidates. Don't start this directly, use `company-search-candidates' or `company-filter-candidates'." - nil company-search-lighter nil + :lighter company-search-lighter (if company-search-mode (if (company-manual-begin) (progn @@ -2142,24 +2557,6 @@ With ARG, move by that many elements." (company-set-selection (- company-selection company-tooltip-limit)))))) -(defvar company-pseudo-tooltip-overlay) - -(defvar company-tooltip-offset) - -(defun company--inside-tooltip-p (event-col-row row height) - (let* ((ovl company-pseudo-tooltip-overlay) - (column (overlay-get ovl 'company-column)) - (width (overlay-get ovl 'company-width)) - (evt-col (car event-col-row)) - (evt-row (cdr event-col-row))) - (and (>= evt-col column) - (< evt-col (+ column width)) - (if (> height 0) - (and (> evt-row row) - (<= evt-row (+ row height) )) - (and (< evt-row row) - (>= evt-row (+ row height))))))) - (defun company--event-col-row (event) (company--posn-col-row (event-start event))) @@ -2254,11 +2651,22 @@ inserted." (when company-candidates (setq this-command 'company-complete-common))))) -(defun company-complete-number (n) - "Insert the Nth candidate visible in the tooltip. -To show the number next to the candidates in some backends, enable -`company-show-numbers'. When called interactively, uses the last typed -character, stripping the modifiers. That character must be a digit." +(define-obsolete-function-alias + 'company-complete-number + 'company-complete-tooltip-row + "0.9.14") + +(defun company-complete-tooltip-row (number) + "Insert a candidate visible on the tooltip's row NUMBER. + +Inserts one of the first ten candidates, +numbered according to the current scrolling position starting with 1. + +When called interactively, uses the last typed digit, stripping the +modifiers and translating 0 into 10, so `M-1' inserts the first visible +candidate, and `M-0' insert to 10th one. + +To show hint numbers beside the candidates, enable `company-show-quick-access'." (interactive (list (let* ((type (event-basic-type last-command-event)) (char (if (characterp type) @@ -2266,14 +2674,34 @@ character, stripping the modifiers. That character must be a digit." type ;; Keypad number, if bound directly. (car (last (string-to-list (symbol-name type)))))) - (n (- char ?0))) - (if (zerop n) 10 n)))) + (number (- char ?0))) + (if (zerop number) 10 number)))) + (company--complete-nth (1- number))) + +(defun company-complete-quick-access (row) + "Insert a candidate visible on a ROW matched by a quick-access key binding. +See `company-quick-access-keys' for more details." + (interactive + (list (let* ((event-type (event-basic-type last-command-event)) + (event-string (if (characterp event-type) + (string event-type) + (error "Unexpected input")))) + (cl-position event-string company-quick-access-keys :test 'equal)))) + (when row + (company--complete-nth row))) + +(defvar-local company-tooltip-offset 0 + "Current scrolling state of the tooltip. +Represented by the index of the first visible completion candidate +from the candidates list.") + +(defun company--complete-nth (row) + "Insert a candidate visible on the tooltip's zero-based ROW." (when (company-manual-begin) - (and (or (< n 1) (> n (- company-candidates-length - company-tooltip-offset))) - (user-error "No candidate number %d" n)) - (cl-decf n) - (company-finish (nth (+ n company-tooltip-offset) + (and (or (< row 0) (>= row (- company-candidates-length + company-tooltip-offset))) + (user-error "No candidate on the row number %d" row)) + (company-finish (nth (+ row company-tooltip-offset) company-candidates)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -2521,10 +2949,6 @@ If SHOW-VERSION is non-nil, show the version in the echo area." ;;; pseudo-tooltip ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar-local company-pseudo-tooltip-overlay nil) - -(defvar-local company-tooltip-offset 0) - (defvar-local company--tooltip-current-width 0) (defun company-tooltip--lines-update-offset (selection num-lines limit) @@ -2556,7 +2980,7 @@ If SHOW-VERSION is non-nil, show the version in the echo area." ;;; propertize -(defsubst company-round-tab (arg) +(defun company-round-tab (arg) (* (/ (+ arg tab-width) tab-width) tab-width)) (defun company-plainify (str) @@ -2572,12 +2996,25 @@ If SHOW-VERSION is non-nil, show the version in the echo area." (pop copy)) (apply 'concat pieces))) +(defun company--common-or-matches (value) + (let ((matches (company-call-backend 'match value))) + (when (and matches + company-common + (listp matches) + (= 1 (length matches)) + (= 0 (caar matches)) + (> (length company-common) (cdar matches))) + (setq matches nil)) + (when (integerp matches) + (setq matches `((0 . ,matches)))) + (or matches + (and company-common `((0 . ,(length company-common)))) + nil))) + (defun company-fill-propertize (value annotation width selected left right) (let* ((margin (length left)) - (common (or (company-call-backend 'match value) - (if company-common - (string-width company-common) - 0))) + (company-common (and company-common (company--clean-string company-common))) + (common (company--common-or-matches value)) (_ (setq value (company-reformat (company--pre-render value)) annotation (and annotation (company--pre-render annotation t)))) (ann-ralign company-tooltip-align-annotations) @@ -2605,48 +3042,51 @@ If SHOW-VERSION is non-nil, show the version in the echo area." right))) (setq width (+ width margin (length right))) - ;; TODO: Use add-face-text-property in Emacs 24.4 (font-lock-append-text-property 0 width 'mouse-face 'company-tooltip-mouse line) (when (< ann-start ann-end) - (font-lock-append-text-property ann-start ann-end 'face - (if selected - 'company-tooltip-annotation-selection - 'company-tooltip-annotation) - line)) + (add-face-text-property ann-start ann-end + (if selected + 'company-tooltip-annotation-selection + 'company-tooltip-annotation) + t line)) (cl-loop with width = (- width (length right)) - for (comp-beg . comp-end) in (if (integerp common) `((0 . ,common)) common) + for (comp-beg . comp-end) in common for inline-beg = (+ margin comp-beg) for inline-end = (min (+ margin comp-end) width) when (< inline-beg width) - do (font-lock-prepend-text-property inline-beg inline-end 'face - (if selected - 'company-tooltip-common-selection - 'company-tooltip-common) - line)) + do (add-face-text-property inline-beg inline-end + (if selected + 'company-tooltip-common-selection + 'company-tooltip-common) + nil line)) (when (let ((re (funcall company-search-regexp-function company-search-string))) (and (not (string= re "")) - (string-match re value (length company-prefix)))) + (string-match re value))) (pcase-dolist (`(,mbeg . ,mend) (company--search-chunks)) (let ((beg (+ margin mbeg)) (end (+ margin mend)) (width (- width (length right)))) (when (< beg width) - (font-lock-prepend-text-property beg (min end width) 'face - (if selected - 'company-tooltip-search-selection - 'company-tooltip-search) - line))))) + (add-face-text-property beg (min end width) + (if selected + 'company-tooltip-search-selection + 'company-tooltip-search) + nil line))))) (when selected - (font-lock-append-text-property 0 width 'face - 'company-tooltip-selection - line)) - (font-lock-append-text-property 0 width 'face - 'company-tooltip - line) + (add-face-text-property 0 width 'company-tooltip-selection t line)) + + (when (company-call-backend 'deprecated value) + (add-face-text-property margin + (min + (+ margin (length value)) + (- width (length right))) + 'company-tooltip-deprecated t line)) + + (add-face-text-property 0 width 'company-tooltip t line) line)) (defun company--search-chunks () @@ -2724,7 +3164,14 @@ If SHOW-VERSION is non-nil, show the version in the echo area." (company-safe-substring old (+ offset (length new))))) (defun company--show-numbers (numbered) - (format " %d" (mod numbered 10))) + (format " %s" (if (<= numbered 10) + (mod numbered 10) + " "))) +(make-obsolete + 'company--show-numbers + "use `company-quick-access-hint-key' instead, +but adjust the expected values appropriately." + "0.9.14") (defsubst company--window-height () (if (fboundp 'window-screen-lines) @@ -2738,18 +3185,6 @@ If SHOW-VERSION is non-nil, show the version in the echo area." (cl-decf ww)) (when (bound-and-true-p display-line-numbers) (cl-decf ww (+ 2 (line-number-display-width)))) - (unless (or (display-graphic-p) - (version< "24.3.1" emacs-version)) - ;; Emacs 24.3 and earlier included margins - ;; in window-width when in TTY. - (cl-decf ww - (let ((margins (window-margins))) - (+ (or (car margins) 0) - (or (cdr margins) 0))))) - (when (and word-wrap - (version< emacs-version "24.4.51.5")) - ;; http://debbugs.gnu.org/19300 - (cl-decf ww)) ;; whitespace-mode with newline-mark (when (and buffer-display-table (aref buffer-display-table ?\n)) @@ -2777,8 +3212,10 @@ If SHOW-VERSION is non-nil, show the version in the echo area." (mapcar (lambda (f) (company--face-attribute f attr)) face))))) -(defun company--replacement-string (lines old column nl &optional align-top) - (cl-decf column company-tooltip-margin) +(defun company--replacement-string (lines column-offset old column nl &optional align-top) + (cl-decf column column-offset) + + (when (< column 0) (setq column 0)) (when (and align-top company-tooltip-flip-when-above) (setq lines (reverse lines))) @@ -2789,31 +3226,25 @@ If SHOW-VERSION is non-nil, show the version in the echo area." (when (> width remaining-cols) (cl-decf column (- width remaining-cols)))) - (let ((offset (and (< column 0) (- column))) - new) - (when offset - (setq column 0)) + (let (new) (when align-top ;; untouched lines first (dotimes (_ (- (length old) (length lines))) (push (pop old) new))) ;; length into old lines. (while old - (push (company-modify-line (pop old) - (company--offset-line (pop lines) offset) - column) + (push (company-modify-line (pop old) (pop lines) column) new)) ;; Append whole new lines. (while lines - (push (concat (company-space-string column) - (company--offset-line (pop lines) offset)) + (push (concat (company-space-string column) (pop lines)) new)) ;; XXX: Also see branch 'more-precise-extend'. - (let* ((nl-face (list - :extend t + (let* ((nl-face `(,@(when (version<= "27" emacs-version) + '(:extend t)) :inverse-video nil - :background (or (company--face-attribute 'default :background) + :background ,(or (company--face-attribute 'default :background) (face-attribute 'default :background nil t)))) (str (apply #'concat (when nl " \n") @@ -2821,20 +3252,16 @@ If SHOW-VERSION is non-nil, show the version in the echo area." ;; https://debbugs.gnu.org/cgi/bugreport.cgi?bug=42552#23 (lambda (line) (list line (propertize "\n" 'face nl-face))) (nreverse new))))) - ;; Use add-face-text-property in Emacs 24.4 ;; https://debbugs.gnu.org/38563 - (font-lock-append-text-property 0 (length str) 'face 'default str) + (add-face-text-property 0 (length str) 'default t str) (when nl (put-text-property 0 1 'cursor t str)) str))) -(defun company--offset-line (line offset) - (if (and offset line) - (substring line offset) - line)) - (defun company--create-lines (selection limit) (let ((len company-candidates-length) (window-width (company--window-width)) + left-margins + left-margin-size lines width lines-copy @@ -2872,20 +3299,38 @@ If SHOW-VERSION is non-nil, show the version in the echo area." len (min limit len) lines-copy lines) - (cl-decf window-width (* 2 company-tooltip-margin)) (when scrollbar-bounds (cl-decf window-width)) + (when company-format-margin-function + (let ((lines-copy lines-copy) + res) + (dotimes (i len) + (push (funcall company-format-margin-function + (pop lines-copy) + (equal selection i)) + res)) + (setq left-margins (nreverse res)))) + + ;; XXX: format-function outputting shorter strings than the + ;; default margin is not supported (yet?). + (setq left-margin-size (apply #'max company-tooltip-margin + (mapcar #'length left-margins))) + + (cl-decf window-width company-tooltip-margin) + (cl-decf window-width left-margin-size) + (dotimes (_ len) (let* ((value (pop lines-copy)) - (annotation (company-call-backend 'annotation value))) + (annotation (company-call-backend 'annotation value)) + (left (or (pop left-margins) + (company-space-string left-margin-size)))) (setq value (company--clean-string value)) (when annotation (setq annotation (company--clean-string annotation)) (when company-tooltip-align-annotations ;; `lisp-completion-at-point' adds a space. - ;; FIXME: Use `string-trim' in Emacs 24.4 - (setq annotation (comment-string-strip annotation t nil)))) - (push (cons value annotation) items) + (setq annotation (string-trim-left annotation)))) + (push (list value annotation left) items) (setq width (max (+ (length value) (if (and annotation company-tooltip-align-annotations) (1+ (length annotation)) @@ -2895,7 +3340,7 @@ If SHOW-VERSION is non-nil, show the version in the echo area." (setq width (min window-width company-tooltip-maximum-width (max company-tooltip-minimum-width - (if company-show-numbers + (if company-show-quick-access (+ 2 width) width)))) @@ -2904,28 +3349,31 @@ If SHOW-VERSION is non-nil, show the version in the echo area." (setq company--tooltip-current-width width)) (let ((items (nreverse items)) - (numbered (if company-show-numbers 0 99999)) + (row (if company-show-quick-access 0 99999)) new) (when previous - (push (company--scrollpos-line previous width) new)) + (push (company--scrollpos-line previous width left-margin-size) new)) (dotimes (i len) (let* ((item (pop items)) (str (car item)) - (annotation (cdr item)) - (margin (company-space-string company-tooltip-margin)) - (left margin) - (right margin) - (width width)) - (when (< numbered 10) - (cl-decf width 2) - (cl-incf numbered) - (setf (if (eq company-show-numbers 'left) left right) - (concat (funcall company-show-numbers-function numbered) - margin))) + (annotation (cadr item)) + (left (nth 2 item)) + (right (company-space-string company-tooltip-margin)) + (width width) + (selected (equal selection i))) + (when company-show-quick-access + (let ((quick-access (gv-ref (if (eq company-show-quick-access 'left) + left right))) + (qa-hint (company-tooltip--format-quick-access-hint + row selected))) + (cl-decf width (string-width qa-hint)) + (setf (gv-deref quick-access) + (concat qa-hint (gv-deref quick-access)))) + (cl-incf row)) (push (concat (company-fill-propertize str annotation - width (equal i selection) + width selected left right) (when scrollbar-bounds @@ -2933,9 +3381,11 @@ If SHOW-VERSION is non-nil, show the version in the echo area." new))) (when remainder - (push (company--scrollpos-line remainder width) new)) + (push (company--scrollpos-line remainder width left-margin-size) new)) - (nreverse new)))) + (cons + left-margin-size + (nreverse new))))) (defun company--scrollbar-bounds (offset limit length) (when (> length limit) @@ -2947,17 +3397,42 @@ If SHOW-VERSION is non-nil, show the version in the echo area." (defun company--scrollbar (i bounds) (propertize " " 'face (if (and (>= i (car bounds)) (<= i (cdr bounds))) - 'company-scrollbar-fg - 'company-scrollbar-bg))) + 'company-tooltip-scrollbar-thumb + 'company-tooltip-scrollbar-track))) -(defun company--scrollpos-line (text width) +(defun company--scrollpos-line (text width fancy-margin-width) (propertize (concat (company-space-string company-tooltip-margin) (company-safe-substring text 0 width) - (company-space-string company-tooltip-margin)) + (company-space-string fancy-margin-width)) 'face 'company-tooltip)) +(defun company-tooltip--format-quick-access-hint (row selected) + "Format a quick-access hint for outputting on a tooltip's ROW. +Value of SELECTED determines the added face." + (propertize (format "%2s" (funcall company-quick-access-hint-function row)) + 'face + (if selected + 'company-tooltip-quick-access-selection + 'company-tooltip-quick-access))) + ;; show +(defvar-local company-pseudo-tooltip-overlay nil) + +(defun company--inside-tooltip-p (event-col-row row height) + (let* ((ovl company-pseudo-tooltip-overlay) + (column (overlay-get ovl 'company-column)) + (width (overlay-get ovl 'company-width)) + (evt-col (car event-col-row)) + (evt-row (cdr event-col-row))) + (and (>= evt-col column) + (< evt-col (+ column width)) + (if (> height 0) + (and (> evt-row row) + (<= evt-row (+ row height) )) + (and (< evt-row row) + (>= evt-row (+ row height))))))) + (defun company--pseudo-tooltip-height () "Calculate the appropriate tooltip height. Returns a negative number if the tooltip should be displayed above point." @@ -2978,6 +3453,11 @@ Returns a negative number if the tooltip should be displayed above point." (setq row (+ row height -1) above t)) + ;; This can happen in Emacs versions which allow arbitrary scrolling, + ;; such as Yamamoto's Mac Port. + (unless (pos-visible-in-window-p (window-start)) + (cl-decf row)) + (let (nl beg end ov args) (save-excursion (setq nl (< (move-to-window-line row) row) @@ -2993,9 +3473,12 @@ Returns a negative number if the tooltip should be displayed above point." (setq company-pseudo-tooltip-overlay ov) (overlay-put ov 'company-replacement-args args) - (let ((lines (company--create-lines selection (abs height)))) + (let* ((lines-and-offset (company--create-lines selection (abs height))) + (lines (cdr lines-and-offset)) + (column-offset (car lines-and-offset))) (overlay-put ov 'company-display - (apply 'company--replacement-string lines args)) + (apply 'company--replacement-string + lines column-offset args)) (overlay-put ov 'company-width (string-width (car lines)))) (overlay-put ov 'company-column column) @@ -3009,12 +3492,14 @@ Returns a negative number if the tooltip should be displayed above point." (defun company-pseudo-tooltip-edit (selection) (let* ((height (overlay-get company-pseudo-tooltip-overlay 'company-height)) - (lines (company--create-lines selection (abs height)))) + (lines-and-offset (company--create-lines selection (abs height))) + (lines (cdr lines-and-offset)) + (column-offset (car lines-and-offset))) (overlay-put company-pseudo-tooltip-overlay 'company-width (string-width (car lines))) (overlay-put company-pseudo-tooltip-overlay 'company-display (apply 'company--replacement-string - lines + lines column-offset (overlay-get company-pseudo-tooltip-overlay 'company-replacement-args))))) @@ -3027,7 +3512,7 @@ Returns a negative number if the tooltip should be displayed above point." (when (overlayp company-pseudo-tooltip-overlay) (overlay-put company-pseudo-tooltip-overlay 'invisible nil) (overlay-put company-pseudo-tooltip-overlay 'line-prefix nil) - (overlay-put company-pseudo-tooltip-overlay 'after-string nil) + (overlay-put company-pseudo-tooltip-overlay 'before-string nil) (overlay-put company-pseudo-tooltip-overlay 'display nil) (overlay-put company-pseudo-tooltip-overlay 'face nil))) @@ -3038,9 +3523,14 @@ Returns a negative number if the tooltip should be displayed above point." ;; Beat outline's folding overlays. ;; And Flymake (53). And Flycheck (110). (overlay-put ov 'priority 111) + ;; visual-line-mode + (when (and (memq (char-before (overlay-start ov)) '(?\s ?\t)) + ;; not eob + (not (nth 2 (overlay-get ov 'company-replacement-args)))) + (setq disp (concat "\n" disp))) ;; No (extra) prefix for the first line. (overlay-put ov 'line-prefix "") - (overlay-put ov 'after-string disp) + (overlay-put ov 'before-string disp) ;; `display' is better than `invisible': ;; https://debbugs.gnu.org/18285 ;; https://debbugs.gnu.org/20847 @@ -3064,6 +3554,18 @@ Returns a negative number if the tooltip should be displayed above point." "`company-mode' frontend similar to a tooltip but based on overlays." (cl-case command (pre-command (company-pseudo-tooltip-hide-temporarily)) + (unhide + (let ((ov company-pseudo-tooltip-overlay)) + (when (> (overlay-get ov 'company-height) 0) + ;; Sleight of hand: if the current line wraps, we adjust the + ;; start of the overlay so that the popup does not zig-zag, + ;; but don't update the popup's background. This seems just + ;; non-annoying enough to avoid the work required for the latter. + (save-excursion + (vertical-motion 1) + (unless (= (point) (overlay-start ov)) + (move-overlay ov (point) (overlay-end ov)))))) + (company-pseudo-tooltip-unhide)) (post-command (unless (when (overlayp company-pseudo-tooltip-overlay) (let* ((ov company-pseudo-tooltip-overlay) @@ -3106,10 +3608,14 @@ Returns a negative number if the tooltip should be displayed above point." (defun company-pseudo-tooltip-unless-just-one-frontend (command) "`company-pseudo-tooltip-frontend', but not shown for single candidates." - (unless (and (eq command 'post-command) + (unless (and (memq command '(post-command unhide)) (company--show-inline-p)) (company-pseudo-tooltip-frontend command))) +(defun company-pseudo-tooltip--ujofwd-on-timer (command) + (when company-candidates + (company-pseudo-tooltip-unless-just-one-frontend-with-delay command))) + (defun company-pseudo-tooltip-unless-just-one-frontend-with-delay (command) "`compandy-pseudo-tooltip-frontend', but shown after a delay. Delay is determined by `company-tooltip-idle-delay'." @@ -3129,8 +3635,11 @@ Delay is determined by `company-tooltip-idle-delay'." (company-call-frontends 'post-command)) (setq company-tooltip-timer (run-with-timer company-tooltip-idle-delay nil - 'company-pseudo-tooltip-unless-just-one-frontend-with-delay + 'company-pseudo-tooltip--ujofwd-on-timer 'post-command)))) + (unhide + (when (overlayp company-pseudo-tooltip-overlay) + (company-pseudo-tooltip-unless-just-one-frontend command))) (t (company-pseudo-tooltip-unless-just-one-frontend command)))) @@ -3141,24 +3650,31 @@ Delay is determined by `company-tooltip-idle-delay'." (defun company-preview-show-at-point (pos completion) (company-preview-hide) - (setq completion (copy-sequence (company--pre-render completion))) - (font-lock-append-text-property 0 (length completion) - 'face 'company-preview - completion) - (font-lock-prepend-text-property 0 (length company-common) - 'face 'company-preview-common - completion) + (let* ((company-common (and company-common + (string-prefix-p company-prefix company-common) + company-common)) + (common (company--common-or-matches completion))) + (setq completion (copy-sequence (company--pre-render completion))) + (add-face-text-property 0 (length completion) 'company-preview + nil completion) + + (cl-loop for (beg . end) in common + do (add-face-text-property beg end 'company-preview-common + nil completion)) ;; Add search string (and (string-match (funcall company-search-regexp-function company-search-string) completion) (pcase-dolist (`(,mbeg . ,mend) (company--search-chunks)) - (font-lock-prepend-text-property mbeg mend - 'face 'company-preview-search - completion))) + (add-face-text-property mbeg mend 'company-preview-search + nil completion))) - (setq completion (company-strip-prefix completion)) + (setq completion (if (string-prefix-p company-prefix completion + (eq (company-call-backend 'ignore-case) + 'keep-prefix)) + (company-strip-prefix completion) + completion)) (and (equal pos (point)) (not (equal completion "")) @@ -3181,7 +3697,7 @@ Delay is determined by `company-tooltip-idle-delay'." (let ((ov company-preview-overlay)) (overlay-put ov (if ptf-workaround 'display 'after-string) completion) - (overlay-put ov 'window (selected-window))))) + (overlay-put ov 'window (selected-window)))))) (defun company-preview-hide () (when company-preview-overlay @@ -3192,6 +3708,17 @@ Delay is determined by `company-tooltip-idle-delay'." "`company-mode' frontend showing the selection as if it had been inserted." (pcase command (`pre-command (company-preview-hide)) + (`unhide + (when company-selection + (let* ((current (nth company-selection company-candidates)) + (company-prefix (if (equal current company-prefix) + ;; Would be more accurate to compare lengths, + ;; but this is shorter. + current + (buffer-substring + (- company-point (length company-prefix)) + (point))))) + (company-preview-show-at-point (point) current)))) (`post-command (when company-selection (company-preview-show-at-point (point) @@ -3200,7 +3727,7 @@ Delay is determined by `company-tooltip-idle-delay'." (defun company-preview-if-just-one-frontend (command) "`company-preview-frontend', but only shown for single candidates." - (when (or (not (eq command 'post-command)) + (when (or (not (memq command '(post-command unhide))) (company--show-inline-p)) (company-preview-frontend command))) @@ -3226,11 +3753,12 @@ Delay is determined by `company-tooltip-idle-delay'." (defun company-preview-common-frontend (command) "`company-mode' frontend preview the common part of candidates." - (when (or (not (eq command 'post-command)) + (when (or (not (memq command '(post-command unhide))) (company-preview-common--show-p)) (pcase command (`pre-command (company-preview-hide)) - (`post-command (company-preview-show-at-point (point) company-common)) + ((or 'post-command 'unhide) + (company-preview-show-at-point (point) company-common)) (`hide (company-preview-hide))))) ;;; echo ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -3255,9 +3783,11 @@ Delay is determined by `company-tooltip-idle-delay'." (message "%s" company-echo-last-msg) (message "")))) -(defun company-echo-show-soon (&optional getter) +(defun company-echo-show-soon (&optional getter delay) (company-echo-cancel) - (setq company-echo-timer (run-with-timer 0 nil 'company-echo-show getter))) + (setq company-echo-timer (run-with-timer (or delay company-echo-delay) + nil + 'company-echo-show getter))) (defun company-echo-cancel (&optional unset) (when company-echo-timer @@ -3265,37 +3795,36 @@ Delay is determined by `company-tooltip-idle-delay'." (when unset (setq company-echo-timer nil))) -(defun company-echo-show-when-idle (&optional getter) - (company-echo-cancel) - (setq company-echo-timer - (run-with-idle-timer company-echo-delay nil 'company-echo-show getter))) - (defun company-echo-format () (let ((selection (or company-selection 0))) (let ((limit (window-body-width (minibuffer-window))) (len -1) - ;; Roll to selection. (candidates (nthcdr selection company-candidates)) - (i (if company-show-numbers selection 99999)) + (numbered (if company-show-quick-access selection 99999)) + (qa-keys-len (length company-quick-access-keys)) comp msg) (while candidates - (setq comp (company-reformat (company--clean-string (pop candidates))) + (setq comp (propertize + (company-reformat (company--clean-string (pop candidates))) + 'face + 'company-echo) len (+ len 1 (length comp))) - (if (< i 10) - ;; Add number. - (progn - (setq comp (propertize (format "%d: %s" i comp) - 'face 'company-echo)) - (cl-incf len 3) - (cl-incf i) - ;; FIXME: Add support for the `match' backend action, and thus, - ;; non-prefix matches. - (add-text-properties 3 (+ 3 (string-width (or company-common ""))) - '(face company-echo-common) comp)) - (setq comp (propertize comp 'face 'company-echo)) - (add-text-properties 0 (string-width (or company-common "")) - '(face company-echo-common) comp)) + (let ((beg 0) + (end (string-width (or company-common "")))) + (when (< numbered qa-keys-len) + (let ((qa-hint + (format "%s: " (funcall + company-quick-access-hint-function + numbered)))) + (setq beg (string-width qa-hint) + end (+ beg end)) + (cl-incf len beg) + (setq comp (propertize (concat qa-hint comp) 'face 'company-echo))) + (cl-incf numbered)) + ;; FIXME: Add support for the `match' backend action, and thus, + ;; non-prefix matches. + (add-text-properties beg end '(face company-echo-common) comp)) (if (>= len limit) (setq candidates nil) (push comp msg))) @@ -3306,19 +3835,21 @@ Delay is determined by `company-tooltip-idle-delay'." (let ((selection (or company-selection 0))) (let ((limit (window-body-width (minibuffer-window))) (len (+ (length company-prefix) 2)) - ;; Roll to selection. (candidates (nthcdr selection company-candidates)) - (i (if company-show-numbers selection 99999)) - msg comp) + (numbered (if company-show-quick-access selection 99999)) + (qa-keys-len (length company-quick-access-keys)) + comp msg) (while candidates (setq comp (company-strip-prefix (pop candidates)) len (+ len 2 (length comp))) - (when (< i 10) - ;; Add number. - (setq comp (format "%s (%d)" comp i)) - (cl-incf len 4) - (cl-incf i)) + (when (< numbered qa-keys-len) + (let ((qa-hint (format " (%s)" + (funcall company-quick-access-hint-function + numbered)))) + (setq comp (concat comp qa-hint)) + (cl-incf len (string-width qa-hint))) + (cl-incf numbered)) (if (>= len limit) (setq candidates nil) (push (propertize comp 'face 'company-echo) msg))) @@ -3335,19 +3866,20 @@ Delay is determined by `company-tooltip-idle-delay'." (defun company-echo-frontend (command) "`company-mode' frontend showing the candidates in the echo area." (pcase command - (`post-command (company-echo-show-soon 'company-echo-format)) + (`post-command (company-echo-show-soon 'company-echo-format 0)) (`hide (company-echo-hide)))) (defun company-echo-strip-common-frontend (command) "`company-mode' frontend showing the candidates in the echo area." (pcase command - (`post-command (company-echo-show-soon 'company-echo-strip-common-format)) + (`post-command (company-echo-show-soon 'company-echo-strip-common-format 0)) (`hide (company-echo-hide)))) (defun company-echo-metadata-frontend (command) "`company-mode' frontend showing the documentation in the echo area." (pcase command - (`post-command (company-echo-show-when-idle 'company-fetch-metadata)) + (`post-command (company-echo-show-soon 'company-fetch-metadata)) + (`unhide (company-echo-show)) (`hide (company-echo-hide)))) (provide 'company) diff --git a/lisp/company/company.info b/lisp/company/company.info new file mode 100644 index 00000000..de7d6dad --- /dev/null +++ b/lisp/company/company.info @@ -0,0 +1,1710 @@ +This is company.info, produced by makeinfo version 6.7 from +company.texi. + +This user manual is for Company version 0.9.14snapshot +(28 December 2021). + +Copyright © 2021 Free Software Foundation, Inc. + + Permission is granted to copy, distribute and/or modify this + document under the terms of the GNU Free Documentation License, + Version 1.3 or any later version published by the Free Software + Foundation. +INFO-DIR-SECTION Emacs misc features +START-INFO-DIR-ENTRY +* Company: (company). A modular text completion framework. +END-INFO-DIR-ENTRY + + +File: company.info, Node: Top, Next: Overview, Up: (dir) + +Company +******* + +Company is a modular text completion framework for GNU Emacs. + +The goal of this document is to lay out the foundational knowledge of +the package, so that the readers of the manual could competently start +adapting Company to their needs and preferences. + +This user manual is for Company version 0.9.14snapshot +(28 December 2021). + +Copyright © 2021 Free Software Foundation, Inc. + + Permission is granted to copy, distribute and/or modify this + document under the terms of the GNU Free Documentation License, + Version 1.3 or any later version published by the Free Software + Foundation. + +* Menu: + +* Overview:: Terminology and Structure +* Getting Started:: Quick Start Guide +* Customization:: User Options +* Frontends:: Frontends Usage Instructions +* Backends:: Backends Usage Instructions +* Troubleshooting:: When Something Goes Wrong +* Index:: + +— The Detailed Node Listing — + +Overview + +* Terminology:: +* Structure:: + +Getting Started + +* Installation:: +* Initial Setup:: +* Usage Basics:: +* Commands:: + +Customization + +* Customization Interface:: +* Configuration File:: + +Frontends + +* Tooltip Frontends:: +* Preview Frontends:: +* Echo Frontends:: +* Candidates Search:: +* Filter Candidates:: +* Quick Access a Candidate:: + +Backends + +* Backends Usage Basics:: +* Grouped Backends:: +* Package Backends:: +* Candidates Post-Processing:: + + + +File: company.info, Node: Overview, Next: Getting Started, Prev: Top, Up: Top + +1 Overview +********** + +“Company” is a modular text completion framework for GNU Emacs. + +In other words, it is a package for retrieving, manipulating, and +displaying text completion candidates. It aims to assist developers, +writers, and scientists during code and text writing. + +* Menu: + +* Terminology:: +* Structure:: + + +File: company.info, Node: Terminology, Next: Structure, Up: Overview + +1.1 Terminology +=============== + +“Completion” is an act of intelligibly guessing possible variants of +words based on already typed characters. To “complete” a word means to +insert a correctly guessed variant into the buffer. + +Consequently, the “candidates” are the aforementioned guessed variants +of words. Each of the candidates has the potential to be chosen for +successful completion. And each of the candidates contains the +initially typed characters: either only at the beginning (so-called +“prefix matches”), or also inside (“non-prefix matches”) of a candidate +(1). + +The package’s name “Company” is based on the combination of the two +words: ‘Complete’ and ‘Anything’. These words reflect the package’s +commitment to handling completion candidates and its extensible nature +allowing it to cover a wide range of usage scenarios. + + ---------- Footnotes ---------- + + (1) A good starting point to learn about types of matches is to play +with the Emacs’s user option ‘completion-styles’. For illustrations on +how Company visualizes the matches, *note Frontends::. + + +File: company.info, Node: Structure, Prev: Terminology, Up: Overview + +1.2 Structure +============= + +The Company is easily extensible because its significant building blocks +are pluggable modules: backends (*note Backends::) and frontends (*note +Frontends::). + +The “backends” are responsible for retrieving completion candidates; +which are then outputted by the “frontends”. For an easy and quick +initial setup, Company is supplied with the preconfigured sets of the +backends and frontends. The default behavior of the modules can be +adjusted per particular needs, goals, and preferences. It is also +typical to utilize backends from a variety of third-party libraries +(https://github.com/company-mode/company-mode/wiki/Third-Party-Packages), +developed to be pluggable with Company. + +But Company consists not only of the backends and frontends. + +A core of the package plays the role of a controller, connecting the +modules, making them work together; and exposing configurations and +commands for a user to operate with. For more details, *note +Customization:: and *note Commands::. + +Also, Company is bundled with an alternative workflow configuration +“company-tng” — defining ‘company-tng-frontend’, ‘company-tng-mode’, and +‘company-tng-map’ — that allows performing completion with just . +To enable this configuration, add the following line to the Emacs +initialization file (*note (emacs)Init File::): + + (add-hook 'after-init-hook 'company-tng-mode) + + +File: company.info, Node: Getting Started, Next: Customization, Prev: Overview, Up: Top + +2 Getting Started +***************** + +This chapter provides basic instructions for Company setup and usage. + +* Menu: + +* Installation:: +* Initial Setup:: +* Usage Basics:: +* Commands:: + + +File: company.info, Node: Installation, Next: Initial Setup, Up: Getting Started + +2.1 Installation +================ + +Company package is distributed via commonly used package archives in a +form of both stable and development releases. To install Company, type +‘M-x package-install company ’. + +For more details on Emacs package archives, *note (emacs)Packages::. + + +File: company.info, Node: Initial Setup, Next: Usage Basics, Prev: Installation, Up: Getting Started + +2.2 Initial Setup +================= + +The package Company provides a minor mode “company-mode”. + +To activate the _company-mode_, execute the command ‘M-x company-mode’ +that toggles the mode on and off. When it is switched on, the mode line +(*note (emacs)Mode line::) should indicate its presence with an +indicator ‘company’. + +After _company-mode_ had been enabled, the package auto-starts +suggesting completion candidates. The candidates are retrieved and +shown according to the typed characters and the default (until a user +specifies otherwise) configurations. + +To have Company always enabled for the following sessions, add the line +‘(global-company-mode)’ to the Emacs configuration file +(*note (emacs)Init File::). + + +File: company.info, Node: Usage Basics, Next: Commands, Prev: Initial Setup, Up: Getting Started + +2.3 Usage Basics +================ + +By default — having _company-mode_ enabled (*note Initial Setup::) — a +tooltip with completion candidates is shown when a user types in a few +characters. + +To initiate completion manually, use the command ‘M-x company-complete’. + +To select next or previous of the shown completion candidates, use +respectively key bindings ‘C-n’ and ‘C-p’, then do one of the following: + + • Hit to choose a selected candidate for completion. + + • Hit to complete with the “common part”: characters present at + the beginning of all the candidates. + + • Hit ‘C-g’ to stop activity of Company. + + +File: company.info, Node: Commands, Prev: Usage Basics, Up: Getting Started + +2.4 Commands +============ + +Under the hood, mentioned in the previous section keys are bound to the +commands of the out-of-the-box Company. + +‘C-n’ +‘M-n’ + Select the next candidate (‘company-select-next-or-abort’, + ‘company-select-next’). + +‘C-p’ +‘M-p’ + Select the previous candidate (‘company-select-previous-or-abort’, + ‘company-select-previous’). + +‘RET’ +‘’ + Insert the selected candidate (‘company-complete-selection’). + +‘TAB’ +‘’ + Insert the common part of all the candidates + (‘company-complete-common’). + +‘C-g’ +‘’ + Cancel _company-mode_ activity (‘company-abort’). + +‘C-h’ +‘’ + Display a buffer with the documentation for the selected candidate + (‘company-show-doc-buffer’). + +‘C-w’ + Display a buffer with the definition of the selected candidate + (‘company-show-location’). + +The full list of the default key bindings is stored in the variables +‘company-active-map’ and ‘company-search-map’ (1). + +Moreover, Company is bundled with a number of convenience commands that +do not have default key bindings defined. The following examples +illustrate how to assign key bindings to such commands. + + (global-set-key (kbd "") #'company-indent-or-complete-common) + + (with-eval-after-load 'company + (define-key company-active-map (kbd "M-/") #'company-complete)) + + (with-eval-after-load 'company + (define-key company-active-map + (kbd "TAB") + #'company-complete-common-or-cycle) + (define-key company-active-map + (kbd "") + (lambda () + (interactive) + (company-complete-common-or-cycle -1)))) + +In the same manner, an additional key can be assigned to a command or a +command can be unbound from a key. For instance: + + (with-eval-after-load 'company + (define-key company-active-map (kbd "M-.") #'company-show-location) + (define-key company-active-map (kbd "RET") nil)) + + ---------- Footnotes ---------- + + (1) For a more user-friendly output of the pre-defined key bindings, +utilize ‘M-x describe-keymap company-active-map’ or +‘C-h f company-mode’. + + +File: company.info, Node: Customization, Next: Frontends, Prev: Getting Started, Up: Top + +3 Customization +*************** + +Emacs provides two equally acceptable ways for user preferences +configuration: via customization interface (for more details, *note +(emacs)Easy Customization::) and a configuration file +(*note (emacs)Init File::). Naturally, Company can be configured by +both of these approaches. + +* Menu: + +* Customization Interface:: +* Configuration File:: + + +File: company.info, Node: Customization Interface, Next: Configuration File, Up: Customization + +3.1 Customization Interface +=========================== + +In order to employ the customization interface, run +‘M-x customize-group company’. + +This interface outputs all the options available for user customization, +so you may find it beneficial to review this list even if you are going +to configure Company with the configuration file. + +For instructions on how to change the settings, *note (emacs)Changing a +Variable::. + + +File: company.info, Node: Configuration File, Prev: Customization Interface, Up: Customization + +3.2 Configuration File +====================== + +Company is a customization-rich package. This section lists some of the +core settings that influence the overall behavior of the _company-mode_. + + -- User Option: company-minimum-prefix-length + This is one of the values (together with ‘company-idle-delay’), + based on which Company auto-stars looking up completion candidates. + This option configures how many characters have to be typed in by a + user before candidates start to be collected and displayed. An + often choice nowadays is to configure this option to a lower number + than the default value of ‘3’. + + -- User Option: company-idle-delay + This is the second of the options that configure Company’s + auto-start behavior (together with + ‘company-minimum-prefix-length’). The value of this option defines + how fast Company is going to react to the typed input, such that + setting ‘company-idle-delay’ to ‘0’ makes Company react + immediately, ‘nil’ disables auto-starting, and a larger value + postpones completion auto-start for that number of seconds. For an + even fancier setup, set this option value to a predicate function, + as shown in the following example: + + (setq company-idle-delay + (lambda () (if (company-in-string-or-comment) nil 0.3))) + + -- User Option: company-global-modes + This option allows to specify in which major modes _company-mode_ + can be enabled by ‘(global-company-mode)’. *Note Initial Setup::. + The default value of ‘t’ enables Company in all major modes. + Setting ‘company-global-modes’ to ‘nil’ equal in action to toggling + off _global-company-mode_. Providing a list of major modes results + in having _company-mode_ enabled in the listed modes only. For the + opposite result, provide a list of major modes with ‘not’ being the + first element of the list, as shown in the following example: + + (setq company-global-modes '(not erc-mode message-mode eshell-mode)) + + -- User Option: company-selection-wrap-around + Enable this option to loop (cycle) the candidates’ selection: after + selecting the last candidate on the list, a command to select the + next candidate does so with the first candidate. By default, this + option is disabled, which means the selection of the next candidate + stops on the last item. The selection of the previous candidate is + influenced by this option similarly. + + -- User Option: company-require-match + To allow typing in characters that don’t match the candidates, set + the value of this option to ‘nil’. For an opposite behavior (that + is, to disallow non-matching input), set it to ‘t’. By default, + Company is configured to require a matching input only if a user + manually enables completion or selects a candidate; by having the + option configured to call the function ‘company-explicit-action-p’. + + -- User Option: company-lighter-base + This user options allows to configure a string indicator of the + enabled _company-mode_ in the mode line. The default value is + ‘company’. + + -- User Option: company-auto-commit + One more pair of the user options may instruct Company to complete + with the selected candidate by typing one of the + ‘company-auto-commit-chars’ (1). The user option + ‘company-auto-commit’ can be enabled or disabled by setting its + value to one of: ‘nil’, ‘t’, or a predicate function name. *note + Predicate: (eintr)Wrong Type of Argument. + + -- User Option: company-auto-commit-chars + This option acts only when ‘company-auto-commit’ is enabled. The + value can be one of: a string of characters, a list of syntax + description characters (*note (elisp)Syntax Class Table::), or a + predicate function. By default, ‘company-auto-commit-chars’ is set + to the list of the syntax characters: ‘(?\ ?\) ?.)’, which + translates to the whitespaces, close parenthesis, and punctuation. + The particular convenience of this user option values is they do + not act as triggers when they are part of valid completion. + +Hooks +----- + +Company exposes the following life-cycle hooks: + + -- User Option: company-completion-started-hook + + -- User Option: company-completion-cancelled-hook + + -- User Option: company-completion-finished-hook + + -- User Option: company-after-completion-hook + + ---------- Footnotes ---------- + + (1) The options ‘company-auto-commit’ and ‘company-auto-commit-chars’ +used to be called ‘company-auto-complete’ and +‘company-auto-complete-chars’ respectively, which was in more accordance +with the terminology given in this manual. But the resulting +combination of the words ‘auto-complete’ present in those names made it +seem the role of these user options was to configure Company’s +auto-start behavior. Hence, it was chosen to rename the options to, +hopefully, less confusing names. + + +File: company.info, Node: Frontends, Next: Backends, Prev: Customization, Up: Top + +4 Frontends +*********** + +Company is packaged with several frontends and provides a predefined set +of enabled frontends. A list of the enabled frontends can be changed by +configuring the user option ‘company-frontends’. + +Each frontend is simply a function that receives a command and acts +accordingly to it: outputs candidates, hides its output, refreshes +displayed data, and so on. + +All of the Company frontends can be categorized by the type of the +output into the three groups: “tooltip-”, “preview-”, and “echo-” +frontends. We overview these groups in the first sections of this +chapter. The sections that follow are dedicated to the ways the +displayed candidates can be searched, filtered, and quick-accessed. + +* Menu: + +* Tooltip Frontends:: +* Preview Frontends:: +* Echo Frontends:: +* Candidates Search:: +* Filter Candidates:: +* Quick Access a Candidate:: + + +File: company.info, Node: Tooltip Frontends, Next: Preview Frontends, Up: Frontends + +4.1 Tooltip Frontends +===================== + +This group of frontends displays completion candidates in an overlayed +tooltip (aka pop-up). Company provides three _tooltip frontends_, +listed below. + + -- Function: company-pseudo-tooltip-unless-just-one-frontend + This is one of the default frontends. It starts displaying a + tooltip only if more than one completion candidate is available, + which nicely combines — and it is done so by default — with + ‘company-preview-if-just-one-frontend’, *note Preview Frontends::. + + -- Function: company-pseudo-tooltip-frontend + This frontend outputs a tooltip for any number of completion + candidates. + + -- Function: company-pseudo-tooltip-unless-just-one-frontend-with-delay + This is a peculiar frontend, that displays a tooltip only if more + than one candidate is available, and only after a delay. The delay + can be configured with the user option + ‘company-tooltip-idle-delay’. A typical use case for plugging in + this frontend would be displaying a tooltip only on a manual + request (when needed), as shown in the following example: + + (setq company-idle-delay 0 + company-tooltip-idle-delay 10 + company-require-match nil + company-frontends + '(company-pseudo-tooltip-unless-just-one-frontend-with-delay + company-preview-frontend + company-echo-metadata-frontend) + company-backends '(company-capf)) + + (global-set-key (kbd "") + (lambda () + (interactive) + (let ((company-tooltip-idle-delay 0.0)) + (company-complete) + (and company-candidates + (company-call-frontends 'post-command))))) + +User Options +------------ + +To change the _tooltip frontends_ configuration, adjust the following +user options. + + -- User Option: company-tooltip-align-annotations + An “annotation” is a string that carries additional information + about a candidate; such as a data type, function arguments, or + whatever a backend appoints to be a valuable piece of information + about a candidate. By default, the annotations are shown right + beside the candidates. Setting the option value to ‘t’ aligns + annotations to the right side of the tooltip. + + (setq company-tooltip-align-annotations t) + + [image src="./images/small/tooltip-annotations.png"] + + -- User Option: company-tooltip-limit + Controls the maximum number of the candidates shown simultaneously + in the tooltip (the default value is ‘10’). When the number of the + available candidates is larger than this option’s value, Company + paginates the results. + + (setq company-tooltip-limit 4) + + [image src="./images/small/tooltip-limit.png"] + + -- User Option: company-tooltip-offset-display + Use this option to choose in which way to output paginated results. + The default value is ‘scrollbar’. Another supported value is + ‘lines’; choose it to show the quantity of the candidates not + displayed by the current tooltip page. + + (setq company-tooltip-offset-display 'lines) + + [image src="./images/small/tooltip-offset-display.png"] + + -- User Option: company-tooltip-minimum + This user option acts only when a tooltip is shown close to the + bottom of a window. It guarantees visibility of this number of + completion candidates below point. When the number of lines + between point and the bottom of a window is less than + ‘company-tooltip-minimum’ value, the tooltip is displayed above + point. + + (setq company-tooltip-minimum 4) + + [image src="./images/small/tooltip-minimum-below.png"] + + + [image src="./images/small/tooltip-minimum-above.png"] + + -- User Option: company-tooltip-flip-when-above + This is one of the fancy features Company has to suggest. When + this setting is enabled, no matter if a tooltip is shown above or + below point, the candidates are always listed starting near point. + (Putting it differently, the candidates are mirrored horizontally + if a tooltip changes its position, instead of being commonly listed + top-to-bottom.) + + (setq company-tooltip-flip-when-above t) + + [image src="./images/small/tooltip-flip.png"] + + -- User Option: company-tooltip-minimum-width + Sets the minimum width of a tooltip, excluding the margins and the + scroll bar. Changing this value especially makes sense if a user + navigates between tooltip pages. Keeping this value at the default + ‘0’ allows Company to always adapt the width of the tooltip to the + longest shown candidate. Enlarging ‘company-tooltip-minimum-width’ + prevents possible significant shifts in the width of the tooltip + when navigating to the next/previous tooltip page. (For an + alternate solution, see ‘company-tooltip-width-grow-only’.) + + -- User Option: company-tooltip-width-grow-only + This is another way to restrict auto-adaptation of the tooltip + width (another is by adjusting ‘company-tooltip-minimum-width’ + value) when navigating between the tooltip pages. + + -- User Option: company-tooltip-maximum-width + This user option controls the maximum width of the tooltip inner + area. By default, its value is pseudo-limitless, potentially + permitting the output of extremely long candidates. But if long + lines become an issue, set this option to a smaller number, such as + ‘60’ or ‘70’. + + -- User Option: company-tooltip-margin + Controls the width of the “margin” on the sides of the tooltip + inner area. If ‘company-format-margin-function’ is set, + ‘company-tooltip-margin’ defines only the right margin. + + (setq company-tooltip-margin 3) + + [image src="./images/small/tooltip-margin.png"] + +Candidates Icons +---------------- + +An “icon” is an image or a text that represents a candidate’s kind; it +is displayed in front of a candidate. The term “kind” here stands for a +high-level category a candidate fits into. (Such as ‘array’, +‘function’, ‘file’, ‘string’, ‘color’, etc. For an extended list of the +possible _kinds_, see the user option ‘company-text-icons-mapping’ or +the variable ‘company-vscode-icons-mapping’.) + + -- User Option: company-format-margin-function + Allows setting a function to format the left margin of a tooltip + inner area; namely, to output candidate’s _icons_. The predefined + formatting functions are listed below. A user may also set this + option to a custom function. To disable left margin formatting, + set the value of the option to ‘nil’ (this way control over the + size of the left margin returns to the user option + ‘company-tooltip-margin’). + + -- Function: company-vscode-dark-icons-margin + -- Function: company-vscode-light-icons-margin + These functions utilize VSCode dark and light theme icon sets (1). + The related two user options are ‘company-icon-size’ and + ‘company-icon-margin’. + + [image src="./images/small/tooltip-icons-vscode.png"] + + -- Function: company-text-icons-margin + This function produces letters and symbols formatted according to + the ‘company-text-icons-format’. The rest of the user options + affecting this function behavior are listed below. + + [image src="./images/small/tooltip-icons-text.png"] + + -- Function: company-dot-icons-margin + This function produces a colored Unicode symbol of a circle + formatted according to the ‘company-dot-icons-format’. Other user + options that affect the resulting output are listed below. + + [image src="./images/small/tooltip-icons-dot.png"] + +The following user options influence appearance of the _text_ and _dot_ +_icons_. + + -- User Option: company-text-icons-mapping + Lists candidates’ _kinds_ with their corresponding _icons_ + configurations. + + -- User Option: company-text-face-extra-attributes + A list of face attributes to be applied to the _icons_. + + (setq company-text-face-extra-attributes + '(:weight bold :slant italic)) + + [image src="./images/small/tooltip-icon-face.png"] + + -- User Option: company-text-icons-add-background + If this option is enabled, when an _icon_ doesn’t have a background + configured by ‘company-text-icons-mapping’, then a generated + background is applied. + + (setq company-text-icons-add-background t) + + [image src="./images/small/tooltip-icon-bg.png"] + + -- Function: company-detect-icons-margin + This is the default margin formatting function, that applies one of + the ‘company-vscode-*-icons-margin’ functions if ‘vscode’ icons set + is supported; otherwise applies a ‘company-text-icons-margin’ + function. + +Faces +----- + +Out-of-the-box Company defines and configures distinguished faces (*note +(emacs)Faces::) for light and dark themes. Moreover, some of the +built-in and third-party themes fine-tune Company to fit their palettes. +That is why there’s often no real need to make such adjustments on a +user side. However, this chapter presents some hints on where to start +customizing Company interface. + +Namely, the look of a tooltip is controlled by the ‘company-tooltip*’ +named faces. + +The following example hints how a user may approach tooltip faces +customization: + + (custom-set-faces + '(company-tooltip + ((t (:background "ivory" :foreground "MistyRose3")))) + '(company-tooltip-selection + ((t (:background "LemonChiffon1" :foreground "MistyRose4")))) + '(company-tooltip-common ((t (:weight bold :foreground "pink1")))) + '(company-scrollbar-fg ((t (:background "ivory3")))) + '(company-scrollbar-bg ((t (:background "ivory2")))) + '(company-tooltip-annotation ((t (:foreground "MistyRose2"))))) + + [image src="./images/small/tooltip-faces-light.png"] + + ---------- Footnotes ---------- + + (1) SVG images support has to be enabled in Emacs for these icons set +to be used. The supported images types can be checked with ‘C-h v +image-types’. Before compiling Emacs, make sure ‘librsvg’ is installed +on your system. + + +File: company.info, Node: Preview Frontends, Next: Echo Frontends, Prev: Tooltip Frontends, Up: Frontends + +4.2 Preview Frontends +===================== + +Frontends in this group output a completion candidate or a common part +of the candidates temporarily inline, as if a word had already been +completed (1). + + -- Function: company-preview-if-just-one-frontend + This is one of the frontends enabled by default. This frontend + outputs a preview if only one completion candidate is available; it + is a good suit to be combined with + ‘company-pseudo-tooltip-unless-just-one-frontend’, *note Tooltip + Frontends::. + + -- Function: company-preview-frontend + This frontend outputs the first of the available completion + candidates inline for a preview. + + -- Function: company-preview-common-frontend + As the name of this frontend suggests, it outputs for a preview + only a common part of the candidates. + +The look of the preview is controlled by the following faces: +‘company-preview’, ‘company-preview-common’, and +‘company-preview-search’. + + [image src="./images/small/preview-light.png"] + + + [image src="./images/small/preview-dark.png"] + + ---------- Footnotes ---------- + + (1) The candidates retrieved according to ‘non-prefix’ matches (*note +Terminology::) may be shown in full after point. + + +File: company.info, Node: Echo Frontends, Next: Candidates Search, Prev: Preview Frontends, Up: Frontends + +4.3 Echo Frontends +================== + +The frontends listed in this section display information in the Emacs’s +echo area, *note (emacs)Echo Area::. + + -- Function: company-echo-metadata-frontend + This frontend is a part of the predefined frontends set. Its + responsibility is to output a short documentation string for a + completion candidate in the echo area. + + [image src="./images/small/echo-meta.png"] + + +The last pair of the built-in frontends isn’t that commonly used and not +as full-featured as the previously reviewed _tooltip-_ and _preview-_ +frontends, but still, feel free to play with them and have some fun! + + -- Function: company-echo-frontend + This frontend outputs all the available completion candidates in + the echo area. + + [image src="./images/small/echo.png"] + + -- Function: company-echo-strip-common-frontend + It acts similarly to the previous frontend but outputs a common + part of the candidates once for all of them. + + [image src="./images/small/echo-strip.png"] + + -- User Option: company-echo-truncate-lines + This is the only _echo frontends_ targeted setting. When enabled, + the output is truncated to fit the echo area. This setting is set + to ‘t’ by default. + +To apply visual changes to the output of these frontends, configure the +faces ‘company-echo’ and ‘company-echo-common’. + + +File: company.info, Node: Candidates Search, Next: Filter Candidates, Prev: Echo Frontends, Up: Frontends + +4.4 Candidates Search +===================== + +By default, when _company-mode_ is in action, a key binding ‘C-s’ starts +looking for matches to additionally typed characters among the displayed +candidates. When a search is initiated, an indicator +‘Search: CHARACTERS’ is shown in the Emacs’s mode line. + +To quit the search mode, hit ‘C-g’. + + -- User Option: company-search-regexp-function + The value of this user option must be a function that interprets + the search input. By default it is set to the function + ‘regexp-quote’, with looks for an exact match. Company defines + several more functions suitable for this option. They are listed + below. + + -- Function: company-search-words-regexp + Searches for words separated with spaces in the given order. + + -- Function: company-search-words-in-any-order-regexp + Searches for words separated with spaces in any order. + + -- Function: company-search-flex-regexp + Searches for characters in the given order, with anything in + between. + +Search matches are distinguished by the ‘company-tooltip-search’ and +‘company-tooltip-search-selection’ faces. + + [image src="./images/small/tooltip-search.png"] + + +File: company.info, Node: Filter Candidates, Next: Quick Access a Candidate, Prev: Candidates Search, Up: Frontends + +4.5 Filter Candidates +===================== + +Candidates filtering is started by typing the default key binding +‘C-M-s’. Filtering acts on a par with the search (*note Candidates +Search::), indicating its activation by the text ‘Filter: CHARACTERS’ in +the mode line and influencing the displayed candidates. The difference +is that the filtering, as its name suggests, keeps displaying only the +matching candidates (in addition to distinguishing the matches with a +face). + +To quit the filtering, hit ‘C-g’. To toggle between search and filter +states, use key binding ‘C-o’. + + [image src="./images/small/tooltip-filter.png"] + + +File: company.info, Node: Quick Access a Candidate, Prev: Filter Candidates, Up: Frontends + +4.6 Quick Access a Candidate +============================ + +Company provides a way to choose a candidate for completion without +having to navigate to that candidate: by hitting one of the quick-access +keys. By default, quick-access key bindings utilize a modifier +and one of the digits, such that pressing ‘M-1’ completes with the first +candidate on the list and ‘M-0’ with the tenth candidate. + +If ‘company-show-quick-access’ is enabled, _tooltip-_ and _echo-_ +frontends show quick-access hints. + + (setq company-show-quick-access 'left) + + [image src="./images/small/tooltip-quick-access.png"] + + + [image src="./images/small/echo-qa.png"] + + + [image src="./images/small/echo-strip-qa.png"] + +To customize the key bindings, either do it via Customization Interface +(*note Customization Interface::) or use the following approach: + + (custom-set-variables + '(company-quick-access-keys '("a" "o" "e" "u" "i")) + '(company-quick-access-modifier 'super)) + +A modifier should be one of ‘meta’, ‘super’, ‘hyper’, ‘ control’. + +The following example applies a bit of customization and demonstrates +how to change quick-access hints faces. + + (setq company-show-quick-access t) + + (custom-set-faces + '(company-tooltip-quick-access ((t (:foreground "pink1")))) + '(company-tooltip-quick-access-selection + ((t (:foreground "pink1" :slant italic))))) + + [image src="./images/small/tooltip-qa-faces-light.png"] + + +File: company.info, Node: Backends, Next: Troubleshooting, Prev: Frontends, Up: Top + +5 Backends +********** + +We can metaphorically say that each backend is like an engine. (The +reality is even better since backends are just functions.) Fueling such +an engine with a command causes the production of material for Company +to move further on. Typically, moving on means outputting that material +to a user via one or several configured frontends, *note Frontends::. + +Just like Company provides a preconfigured list of the enabled +frontends, it also defines a list of the backends to rely on by default. +This list is stored in the user option ‘company-backends’. The +docstring of this variable has been a source of valuable information for +years. That’s why we’re going to stick to a tradition and suggest +reading the output of ‘C-h v company-backends’ for insightful details +about backends. Nevertheless, the fundamental concepts are described in +this user manual too. + +* Menu: + +* Backends Usage Basics:: +* Grouped Backends:: +* Package Backends:: +* Candidates Post-Processing:: + + +File: company.info, Node: Backends Usage Basics, Next: Grouped Backends, Up: Backends + +5.1 Backends Usage Basics +========================= + +One of the significant concepts to understand about Company is that the +package relies on one backend at a time (1). The backends are invoked +one by one, in the sequential order of the items on the +‘company-backends’ list. + +The name of the currently active backend is shown in the mode line and +in the output of the command ‘M-x company-diag’. + +In most cases (mainly to exclude false-positive results), the next +backend is not invoked automatically. For the purpose of invoking the +next backend, use the command ‘company-other-backend’: either by calling +it with ‘M-x’ or by binding the command to the keys of your choice, such +as: + + (global-set-key (kbd "C-c C-/") #'company-other-backend) + +It is also possible to specifically start a backend with the command +‘M-x company-begin-backend’ or by calling a backend by its name, for +instance: ‘M-x company-capf’. As usual for Emacs, such backends calls +can be assigned to key bindings, for example: + + (global-set-key (kbd "C-c y") 'company-yasnippet) + + ---------- Footnotes ---------- + + (1) The grouped backends act as one complex backend. *Note Grouped +Backends::. + + +File: company.info, Node: Grouped Backends, Next: Package Backends, Prev: Backends Usage Basics, Up: Backends + +5.2 Grouped Backends +==================== + +In many cases, it can be desirable to receive candidates from several +backends simultaneously. This can be achieved by configuring “grouped +backends”: a sub-list of backends in the ‘company-backends’ list, that +is handled specifically by Company. + +The most important part of this handling is the merge of the completion +candidates from the grouped backends. (But only from the backends that +return the same _prefix_ value, see ‘C-h v company-backends’ for more +details.) + +To keep the candidates organized in accordance with the grouped backends +order, add the keyword ‘:separate’ to the list of the grouped backends. +The following example illustrates this. + + (defun my-text-mode-hook () + (setq-local company-backends + '((company-dabbrev company-ispell :separate) + company-files))) + + (add-hook 'text-mode-hook #'my-text-mode-hook) + +Another keyword ‘:with’ helps to make sure the results from major/minor +mode agnostic backends (such as _company-yasnippet_, +_company-dabbrev-code_) are returned without preventing results from +context-aware backends (such as _company-capf_ or _company-clang_). For +this feature to work, put backends dependent on a mode at the beginning +of the grouped backends list, then put a keyword ‘:with’, and only then +put context agnostic backend(s), as shown in the following concise +example: + + (setq company-backends '((company-capf :with company-yasnippet))) + + +File: company.info, Node: Package Backends, Next: Candidates Post-Processing, Prev: Grouped Backends, Up: Backends + +5.3 Package Backends +==================== + +The following sections give a short overview of the commonly used +backends bundled with Company. Each section is devoted to one of the +roughly outlined groups of the backends. + +Some of the backends expose user options for customization; a few of +these options are introduced below. For those who would like to fetch +the full list of a backend’s user options, we suggest doing one of the +following: + + • Execute command ‘M-x customize-group ’. + + • Open the source file of the backend and run + ‘M-x occur ^(defcustom’. + + − Optionally, search for the matches with + ‘M-x isearch (defcustom’. + +* Menu: + +* Code Completion:: +* Text Completion:: +* File Name Completion:: +* Template Expansion:: + + +File: company.info, Node: Code Completion, Next: Text Completion, Up: Package Backends + +5.3.1 Code Completion +--------------------- + + -- Function: company-capf + In the Emacs’s world, the current tendency is to have the + completion logic provided by ‘completion-at-point-functions’ (CAPF) + implementations. [Among the other things, this is what the popular + packages that support language server protocol (LSP) also rely on.] + + Since _company-capf_ works as a bridge to the standard CAPF + facility, it is probably the most often used and recommended + backend nowadays, including for Emacs Lisp coding. + + Just to illustrate, the following minimal backends setup + + (setq company-backends '((company-capf company-dabbrev-code))) + + might cover a large number of basic use cases, especially so in + major modes that have CAPF support implemented. + + For more details on CAPF, *note (elisp)Completion in Buffers::. + + -- Function: company-dabbrev-code + This backend works similarly to the built-in Emacs package + _dabbrev_, searching for completion candidates inside the contents + of the open buffer(s). Internally, its based on the backend + _company-dabbrev_ (*note Text Completion::). + + -- Function: company-keywords + This backend provides completions for many of the widely spread + programming languages _keywords_: words bearing specific meaning in + a language. + + -- Function: company-clang + As the name suggests, use this backend to get completions from + _Clang_ compiler; that is, for the languages in the _C_ language + family: _C_, _C++_, _Objective-C_. + + -- Function: company-semantic + This backend relies on a built-in Emacs package that provides + language-aware editing commands based on source code parsers, *note + (emacs)Semantic::. Having enabled _semantic-mode_ makes it to be + used by the CAPF mechanism (*note (emacs)Symbol Completion::), + hence a user may consider enabling _company-capf_ backend instead. + + -- Function: company-etags + This backend works on top of a built-in Emacs package _etags_, + *note (emacs)Tags Tables::. Similarly to aforementioned _Semantic_ + usage, tags-based completions now are a part of the Emacs’ CAPF + facility, therefore a user may consider switching to _company-capf_ + backend. + + +File: company.info, Node: Text Completion, Next: File Name Completion, Prev: Code Completion, Up: Package Backends + +5.3.2 Text Completion +--------------------- + + -- Function: company-dabbrev + This backend works similarly to the built-in Emacs package + _dabbrev_, searching for completion candidates inside the contents + of the open buffer(s). It is one of the often used backends, and + it has several interesting options for configuration. Let’s review + a few of them. + + -- User Option: company-dabbrev-minimum-length + This option sets the minimum length of a completion candidate + to collect from the text. The default value of ‘4’ is + intended to prevent potential performance issues. But in many + scenarios, it may be acceptable to lower this value. Note + that this option also affects the behavior of the + _company-dabbrev-code_ backend. + + (setq company-dabbrev-minimum-length 2) + + -- User Option: company-dabbrev-other-buffers + By default, _company-dabbrev_ collects completion candidates + from all not ignored buffers (see more on that below). This + behavior can be changed to collecting candidates from the + current buffer only (by setting the value to ‘nil’) or from + the buffers with the same major mode: + + (setq company-dabbrev-other-buffers t) + + -- User Option: company-dabbrev-ignore-buffers + The value of this option should be a regexp or a predicate + function that can be used to match a buffer name. The matched + buffers are omitted from the search for completion candidates. + + The last two options described here relate to handling uppercase + and lowercase letters in completion candidates. The illustrative + examples given below can be reproduced in the ‘*scratch*’ buffer, + with the word ‘Enjoy’ typed in, and with this initial setup: + + (setq-local company-backends '(company-dabbrev) + company-dabbrev-other-buffers nil + company-dabbrev-ignore-case nil + company-dabbrev-downcase nil) + + -- User Option: company-dabbrev-ignore-case + This user option controls whether the case is ignored when + collecting completion candidates. When the option is set to + ‘nil’, ‘Enjoy’ is suggested as a completion candidate for the + typed ‘Enj’ letters, but not for ‘enj’. When the option is + set to ‘t’, ‘Enjoy’ is suggested as a candidate for both ‘Enj’ + and ‘enj’ input; note that ‘enj’ prefix is “overwritten” by + completing with the ‘Enjoy’ candidate. The third, default, + type of behavior solves this issue, keeping the case of the + typed prefix (and still collecting candidates + case-insensitively): + + (setq company-dabbrev-ignore-case 'keep-prefix) + + Now we can type ‘enj’, complete it with the suggested ‘Enjoy’, + and _enjoy_ the result. + + -- User Option: company-dabbrev-downcase + This user option controls whether completion candidates are + down-cased before their display. When the option is set to + ‘nil’, no transformation is performed; in the environment + described above, typing ‘Enj’ results in the candidate ‘Enjoy’ + being suggested. When the option is set to ‘t’, the + down-cased candidate ‘enjoy’ is suggested. By default, this + option is set to ‘case-replace’, meaning taking a value of the + Emacs’s variable ‘case-replace’ (‘t’ is the current default). + + + -- Function: company-ispell + This backend returns completion candidates collected by _Ispell_, a + built-in Emacs package that performs spell-checking. *Note + Checking and Correcting Spelling: (emacs)Spelling. Note that + _Ispell_ uses only one dictionary at a time (combining several + dictionaries into one file is an accepted practice). By default, + _company-ispell_ suggests candidates from a dictionary specified by + the Emacs’s setting ‘ispell-complete-word-dict’. + + -- User Option: company-ispell-dictionary + Optionally, set a file path for _company-ispell_ to use + another dictionary. + + +File: company.info, Node: File Name Completion, Next: Template Expansion, Prev: Text Completion, Up: Package Backends + +5.3.3 File Name Completion +-------------------------- + + -- Function: company-files + This backend can be used to retrieve completion candidates for the + absolute and relative paths in the directory structure of an + operating system. The behavior of the _company-files_ backend can + be adjusted with the two user options. + + -- User Option: company-files-exclusions + It may be desirable to exclude directories or files from the + list of suggested completion candidates. For example, + someone’s setup might look this way: + + (setq company-files-exclusions '(".git/" ".DS_Store")) + + -- User Option: company-files-chop-trailing-slash + This setting is enabled by default, which results in stripping + off a trailing slash from an inserted directory name. On + typing a trailing slash, the process of completion gets + started again, from inside the just inserted directory. + + Setting ‘company-files-chop-trailing-slash’ to ‘nil’ makes + directory names to be inserted as is, with a trailing slash. + In this case, the completion process can be continued, for + example, either by explicitly calling _company-files_ backend + (*note Backends Usage Basics::) or by starting typing a name + of a file/directory known to be located under the inserted + directory. + + +File: company.info, Node: Template Expansion, Prev: File Name Completion, Up: Package Backends + +5.3.4 Template Expansion +------------------------ + + -- Function: company-abbrev + This is a completion backend for a built-in word abbreviation mode + (*note (emacs)Abbrevs::), that allows completing abbreviations with + their expansions. + + -- Function: company-tempo + A backend for users of Tempo + (https://www.lysator.liu.se/~davidk/elisp/), one more built-in + Emacs package for creating and inserting (expanding) templates. + + -- Function: company-yasnippet + Used as a completion backend for the popular third-party template + system YASnippet (https://github.com/joaotavora/yasnippet). + + +File: company.info, Node: Candidates Post-Processing, Prev: Package Backends, Up: Backends + +5.4 Candidates Post-Processing +============================== + +A list of completion candidates, supplied by a backend, can be +additionally manipulated (reorganized, reduced, sorted, etc) before its +output. This is done by adding a processing function name to the user +option ‘company-transformers’ list, for example: + + (setq company-transformers '(delete-consecutive-dups + company-sort-by-occurrence)) + +Company is bundled with several such transformer functions. They are +listed below. + + -- Function: company-sort-by-occurrence + Sorts candidates using ‘company-occurrence-weight-function’ + algorithm. + + -- User Option: company-occurrence-weight-function + Can be set to one of ‘company-occurrence-prefer-closest-above’ + (default) or ‘company-occurrence-prefer-any-closest’. This user + option defines the behavior of the ‘company-sort-by-occurrence’ + transformer function. + + -- Function: company-sort-by-backend-importance + Sorts candidates as two priority groups, differentiated by the + keyword ‘:with’ (*note Grouped Backends::). Backends positioned in + the backends list before the keyword ‘:with’ are treated as more + important. + + -- Function: company-sort-prefer-same-case-prefix + Gives preference to the candidates that match the prefix + case-insensitively. + + +File: company.info, Node: Troubleshooting, Next: Index, Prev: Backends, Up: Top + +6 Troubleshooting +***************** + +If something goes wrong, the first thing we recommend doing is to +execute command ‘M-x company-diag’ and thoroughly study its output. + +This command outputs important details about the internal workings of +Company at the moment of the ‘company-diag’ command execution, including +a responsible backend and a list of completion candidates provided by +it. + +Based on the value of the ‘Used backend’ in the output of the command +‘M-x company-diag’, these possible actions may follow: + + • If the used backend does not belong to the Company package, report + the issue to the corresponding third-party package maintainer(s). + + • If the used backend is ‘company-capf’, then take a look at the line + starting with ‘Value of c-a-p-f:’. The issue could have been + caused by a function listed there. To identify to which package it + belongs, type ‘M-x find-function ’. + +If the aforementioned steps didn’t help to find the cause of the issue, +then file a bug report to +the Company Issue Tracker (https://github.com/company-mode/company-mode/issues), +attaching the following information: + + 1. Output of the ‘M-x company-diag’. + + 2. The exact error message: you can find it in the ‘*Messages*’ + buffer. + + 3. The steps to reproduce the behavior. Ideally, if you can, starting + with a bare Emacs session: ‘emacs -Q’. + + 4. The backtrace of the error, which you can get by running the + command: ‘M-x toggle-debug-on-error’ before reproducing the error. + + +File: company.info, Node: Index, Prev: Troubleshooting, Up: Top + +Index +***** + +* Menu: + +* Key Index:: +* Variable Index:: +* Function Index:: +* Concept Index:: + + +File: company.info, Node: Key Index, Next: Variable Index, Up: Index + +Key Index +========= + +[index] +* Menu: + +* C-g: Usage Basics. (line 20) +* C-g <1>: Commands. (line 30) +* C-g <2>: Candidates Search. (line 11) +* C-g <3>: Filter Candidates. (line 14) +* C-h: Commands. (line 34) +* C-M-s: Filter Candidates. (line 6) +* C-n: Usage Basics. (line 12) +* C-n <1>: Commands. (line 11) +* C-o: Filter Candidates. (line 14) +* C-p: Usage Basics. (line 12) +* C-p <1>: Commands. (line 16) +* C-s: Candidates Search. (line 6) +* C-w: Commands. (line 39) +* M-: Quick Access a Candidate. + (line 6) +* RET: Usage Basics. (line 15) +* RET <1>: Commands. (line 21) +* TAB: Usage Basics. (line 17) +* TAB <1>: Commands. (line 25) + + +File: company.info, Node: Variable Index, Next: Function Index, Prev: Key Index, Up: Index + +Variable Index +============== + +[index] +* Menu: + +* company-after-completion-hook: Configuration File. (line 94) +* company-auto-commit: Configuration File. (line 64) +* company-auto-commit-chars: Configuration File. (line 72) +* company-backends: Backends. (line 12) +* company-backends <1>: Backends Usage Basics. + (line 6) +* company-backends <2>: Grouped Backends. (line 6) +* company-completion-cancelled-hook: Configuration File. (line 90) +* company-completion-finished-hook: Configuration File. (line 92) +* company-completion-started-hook: Configuration File. (line 88) +* company-dabbrev-downcase: Text Completion. (line 64) +* company-dabbrev-ignore-buffers: Text Completion. (line 32) +* company-dabbrev-ignore-case: Text Completion. (line 47) +* company-dabbrev-minimum-length: Text Completion. (line 13) +* company-dabbrev-other-buffers: Text Completion. (line 23) +* company-dot-icons-format: Tooltip Frontends. (line 179) +* company-echo-truncate-lines: Echo Frontends. (line 33) +* company-files-chop-trailing-slash: File Name Completion. + (line 19) +* company-files-exclusions: File Name Completion. + (line 12) +* company-format-margin-function: Tooltip Frontends. (line 153) +* company-frontends: Frontends. (line 6) +* company-global-modes: Configuration File. (line 31) +* company-icon-margin: Tooltip Frontends. (line 164) +* company-icon-size: Tooltip Frontends. (line 164) +* company-idle-delay: Configuration File. (line 17) +* company-ispell-dictionary: Text Completion. (line 84) +* company-lighter-base: Configuration File. (line 59) +* company-minimum-prefix-length: Configuration File. (line 9) +* company-mode: Initial Setup. (line 6) +* company-occurrence-weight-function: Candidates Post-Processing. + (line 21) +* company-require-match: Configuration File. (line 51) +* company-search-regexp-function: Candidates Search. (line 13) +* company-selection-wrap-around: Configuration File. (line 43) +* company-show-quick-access: Quick Access a Candidate. + (line 14) +* company-text-face-extra-attributes: Tooltip Frontends. (line 192) +* company-text-icons-add-background: Tooltip Frontends. (line 200) +* company-text-icons-format: Tooltip Frontends. (line 171) +* company-text-icons-mapping: Tooltip Frontends. (line 188) +* company-tooltip-align-annotations: Tooltip Frontends. (line 52) +* company-tooltip-flip-when-above: Tooltip Frontends. (line 99) +* company-tooltip-idle-delay: Tooltip Frontends. (line 22) +* company-tooltip-limit: Tooltip Frontends. (line 64) +* company-tooltip-margin: Tooltip Frontends. (line 133) +* company-tooltip-maximum-width: Tooltip Frontends. (line 126) +* company-tooltip-minimum: Tooltip Frontends. (line 84) +* company-tooltip-minimum-width: Tooltip Frontends. (line 111) +* company-tooltip-offset-display: Tooltip Frontends. (line 74) +* company-tooltip-width-grow-only: Tooltip Frontends. (line 121) +* company-transformers: Candidates Post-Processing. + (line 6) + + +File: company.info, Node: Function Index, Next: Concept Index, Prev: Variable Index, Up: Index + +Function Index +============== + +[index] +* Menu: + +* company-abbrev: Template Expansion. (line 6) +* company-abort: Commands. (line 30) +* company-begin-backend: Backends Usage Basics. + (line 23) +* company-capf: Code Completion. (line 6) +* company-clang: Code Completion. (line 36) +* company-complete: Usage Basics. (line 10) +* company-complete-common: Commands. (line 25) +* company-complete-selection: Commands. (line 21) +* company-dabbrev: Text Completion. (line 6) +* company-dabbrev-code: Code Completion. (line 25) +* company-detect-icons-margin: Tooltip Frontends. (line 209) +* company-diag: Backends Usage Basics. + (line 11) +* company-diag <1>: Troubleshooting. (line 6) +* company-dot-icons-margin: Tooltip Frontends. (line 178) +* company-echo-frontend: Echo Frontends. (line 21) +* company-echo-metadata-frontend: Echo Frontends. (line 9) +* company-echo-strip-common-frontend: Echo Frontends. (line 27) +* company-etags: Code Completion. (line 48) +* company-files: File Name Completion. + (line 6) +* company-ispell: Text Completion. (line 75) +* company-keywords: Code Completion. (line 31) +* company-mode: Initial Setup. (line 6) +* company-other-backend: Backends Usage Basics. + (line 14) +* company-preview-common-frontend: Preview Frontends. (line 21) +* company-preview-frontend: Preview Frontends. (line 17) +* company-preview-if-just-one-frontend: Preview Frontends. (line 10) +* company-pseudo-tooltip-frontend: Tooltip Frontends. (line 17) +* company-pseudo-tooltip-unless-just-one-frontend: Tooltip Frontends. + (line 11) +* company-pseudo-tooltip-unless-just-one-frontend-with-delay: Tooltip Frontends. + (line 21) +* company-search-flex-regexp: Candidates Search. (line 26) +* company-search-words-in-any-order-regexp: Candidates Search. + (line 23) +* company-search-words-regexp: Candidates Search. (line 20) +* company-select-next: Commands. (line 11) +* company-select-next-or-abort: Commands. (line 11) +* company-select-previous: Commands. (line 16) +* company-select-previous-or-abort: Commands. (line 16) +* company-semantic: Code Completion. (line 41) +* company-show-doc-buffer: Commands. (line 34) +* company-show-location: Commands. (line 39) +* company-sort-by-backend-importance: Candidates Post-Processing. + (line 28) +* company-sort-by-occurrence: Candidates Post-Processing. + (line 17) +* company-sort-prefer-same-case-prefix: Candidates Post-Processing. + (line 34) +* company-tempo: Template Expansion. (line 11) +* company-text-icons-margin: Tooltip Frontends. (line 170) +* company-tng-frontend: Structure. (line 26) +* company-tng-mode: Structure. (line 26) +* company-vscode-dark-icons-margin: Tooltip Frontends. (line 162) +* company-vscode-light-icons-margin: Tooltip Frontends. (line 163) +* company-yasnippet: Template Expansion. (line 16) +* global-company-mode: Initial Setup. (line 18) + + +File: company.info, Node: Concept Index, Prev: Function Index, Up: Index + +Concept Index +============= + +[index] +* Menu: + +* abbrev: Template Expansion. (line 6) +* abort: Usage Basics. (line 20) +* abort <1>: Commands. (line 30) +* activate: Initial Setup. (line 8) +* active backend: Backends Usage Basics. + (line 11) +* active backend <1>: Troubleshooting. (line 15) +* annotation: Tooltip Frontends. (line 53) +* auto-start: Initial Setup. (line 13) +* backend: Structure. (line 6) +* backend <1>: Structure. (line 10) +* backend <2>: Backends Usage Basics. + (line 11) +* backend <3>: Backends Usage Basics. + (line 14) +* backend <4>: Troubleshooting. (line 15) +* backends: Backends. (line 6) +* backends <1>: Backends Usage Basics. + (line 6) +* backends <2>: Grouped Backends. (line 6) +* backends <3>: Package Backends. (line 6) +* basics: Usage Basics. (line 6) +* bug: Troubleshooting. (line 6) +* bug <1>: Troubleshooting. (line 27) +* bundled backends: Package Backends. (line 6) +* cancel: Usage Basics. (line 20) +* cancel <1>: Commands. (line 30) +* candidate: Terminology. (line 10) +* candidate <1>: Usage Basics. (line 12) +* candidate <2>: Usage Basics. (line 15) +* candidate <3>: Preview Frontends. (line 6) +* color: Tooltip Frontends. (line 219) +* color <1>: Quick Access a Candidate. + (line 37) +* common part: Usage Basics. (line 17) +* common part <1>: Commands. (line 25) +* common part <2>: Preview Frontends. (line 6) +* company-echo: Echo Frontends. (line 6) +* company-preview: Preview Frontends. (line 6) +* company-tng: Structure. (line 26) +* company-tooltip: Tooltip Frontends. (line 219) +* company-tooltip-search: Candidates Search. (line 6) +* complete: Terminology. (line 6) +* complete <1>: Usage Basics. (line 12) +* complete <2>: Usage Basics. (line 15) +* complete <3>: Usage Basics. (line 17) +* complete <4>: Commands. (line 21) +* complete <5>: Preview Frontends. (line 6) +* completion: Terminology. (line 6) +* completion <1>: Usage Basics. (line 12) +* completion <2>: Usage Basics. (line 15) +* completion <3>: Usage Basics. (line 17) +* configure: Customization. (line 6) +* configure <1>: Customization Interface. + (line 6) +* configure <2>: Configuration File. (line 6) +* configure <3>: Tooltip Frontends. (line 49) +* configure <4>: Tooltip Frontends. (line 219) +* configure <5>: Preview Frontends. (line 25) +* configure <6>: Echo Frontends. (line 38) +* configure <7>: Candidates Search. (line 30) +* configure <8>: Quick Access a Candidate. + (line 28) +* configure <9>: Quick Access a Candidate. + (line 37) +* custom: Customization. (line 6) +* custom <1>: Customization Interface. + (line 6) +* custom <2>: Configuration File. (line 6) +* custom <3>: Tooltip Frontends. (line 49) +* custom <4>: Tooltip Frontends. (line 219) +* custom <5>: Preview Frontends. (line 25) +* custom <6>: Echo Frontends. (line 38) +* custom <7>: Candidates Search. (line 30) +* custom <8>: Quick Access a Candidate. + (line 28) +* custom <9>: Quick Access a Candidate. + (line 37) +* definition: Commands. (line 39) +* distribution: Installation. (line 6) +* doc: Commands. (line 34) +* duplicate: Candidates Post-Processing. + (line 6) +* echo: Echo Frontends. (line 6) +* enable: Initial Setup. (line 8) +* error: Troubleshooting. (line 6) +* error <1>: Troubleshooting. (line 27) +* expansion: Template Expansion. (line 6) +* extensible: Structure. (line 6) +* face: Tooltip Frontends. (line 219) +* face <1>: Preview Frontends. (line 6) +* face <2>: Preview Frontends. (line 25) +* face <3>: Echo Frontends. (line 6) +* face <4>: Echo Frontends. (line 38) +* face <5>: Candidates Search. (line 6) +* face <6>: Candidates Search. (line 30) +* face <7>: Filter Candidates. (line 6) +* face <8>: Quick Access a Candidate. + (line 37) +* filter: Filter Candidates. (line 6) +* finish: Usage Basics. (line 20) +* finish <1>: Commands. (line 30) +* font: Tooltip Frontends. (line 219) +* font <1>: Quick Access a Candidate. + (line 37) +* frontend: Structure. (line 6) +* frontend <1>: Structure. (line 10) +* frontends: Frontends. (line 6) +* grouped backends: Grouped Backends. (line 6) +* icon: Tooltip Frontends. (line 145) +* install: Installation. (line 6) +* interface: Tooltip Frontends. (line 49) +* interface <1>: Tooltip Frontends. (line 219) +* interface <2>: Preview Frontends. (line 25) +* interface <3>: Echo Frontends. (line 38) +* interface <4>: Candidates Search. (line 30) +* interface <5>: Quick Access a Candidate. + (line 37) +* intro: Initial Setup. (line 6) +* issue: Troubleshooting. (line 6) +* issue tracker: Troubleshooting. (line 27) +* kind: Tooltip Frontends. (line 145) +* location: Commands. (line 39) +* manual: Initial Setup. (line 8) +* manual <1>: Usage Basics. (line 10) +* margin: Tooltip Frontends. (line 134) +* margin <1>: Tooltip Frontends. (line 154) +* minor-mode: Initial Setup. (line 6) +* module: Structure. (line 6) +* module <1>: Structure. (line 10) +* navigate: Usage Basics. (line 12) +* next backend: Backends Usage Basics. + (line 14) +* non-prefix matches: Terminology. (line 10) +* package: Installation. (line 6) +* package backends: Package Backends. (line 6) +* pluggable: Structure. (line 6) +* pop-up: Tooltip Frontends. (line 6) +* prefix matches: Terminology. (line 10) +* preview: Preview Frontends. (line 6) +* quick start: Initial Setup. (line 6) +* quick-access: Quick Access a Candidate. + (line 6) +* quit: Usage Basics. (line 20) +* quit <1>: Commands. (line 30) +* search: Candidates Search. (line 6) +* select: Usage Basics. (line 12) +* select <1>: Commands. (line 11) +* select <2>: Commands. (line 16) +* snippet: Template Expansion. (line 6) +* sort: Candidates Post-Processing. + (line 6) +* stop: Usage Basics. (line 20) +* stop <1>: Commands. (line 30) +* TAB: Structure. (line 26) +* Tab and Go: Structure. (line 26) +* template: Template Expansion. (line 6) +* third-party: Structure. (line 10) +* third-party <1>: Troubleshooting. (line 18) +* tooltip: Tooltip Frontends. (line 6) +* troubleshoot: Troubleshooting. (line 6) +* usage: Usage Basics. (line 6) + + + +Tag Table: +Node: Top569 +Node: Overview1994 +Node: Terminology2402 +Ref: Terminology-Footnote-13389 +Node: Structure3595 +Node: Getting Started5091 +Node: Installation5369 +Node: Initial Setup5752 +Node: Usage Basics6598 +Node: Commands7361 +Ref: Commands-Footnote-19579 +Node: Customization9746 +Node: Customization Interface10218 +Node: Configuration File10751 +Ref: company-auto-commit14058 +Ref: company-auto-commit-chars14480 +Ref: Configuration File-Footnote-115387 +Node: Frontends15901 +Node: Tooltip Frontends16870 +Ref: Tooltip Frontends-Footnote-127239 +Node: Preview Frontends27476 +Ref: Preview Frontends-Footnote-128732 +Node: Echo Frontends28859 +Node: Candidates Search30392 +Node: Filter Candidates31726 +Node: Quick Access a Candidate32506 +Node: Backends34124 +Node: Backends Usage Basics35222 +Ref: Backends Usage Basics-Footnote-136437 +Node: Grouped Backends36521 +Node: Package Backends38150 +Node: Code Completion39079 +Node: Text Completion41448 +Node: File Name Completion45882 +Node: Template Expansion47430 +Node: Candidates Post-Processing48149 +Node: Troubleshooting49626 +Node: Index51299 +Node: Key Index51462 +Node: Variable Index52961 +Node: Function Index57011 +Node: Concept Index61492 + +End Tag Table + + +Local Variables: +coding: utf-8 +End: diff --git a/lisp/company/dir b/lisp/company/dir new file mode 100644 index 00000000..a7ea2be1 --- /dev/null +++ b/lisp/company/dir @@ -0,0 +1,18 @@ +This is the file .../info/dir, which contains the +topmost node of the Info hierarchy, called (dir)Top. +The first time you invoke Info you start off looking at this node. + +File: dir, Node: Top This is the top of the INFO tree + + This (the Directory node) gives a menu of major topics. + Typing "q" exits, "H" lists all Info commands, "d" returns here, + "h" gives a primer for first-timers, + "mEmacs" visits the Emacs manual, etc. + + In Emacs, you can click mouse button 2 on a menu item or cross reference + to select it. + +* Menu: + +Emacs misc features +* Company: (company). A modular text completion framework. diff --git a/lisp/company/icons/LICENSE b/lisp/company/icons/LICENSE new file mode 100644 index 00000000..52bd1459 --- /dev/null +++ b/lisp/company/icons/LICENSE @@ -0,0 +1,395 @@ +Attribution 4.0 International + +======================================================================= + +Creative Commons Corporation ("Creative Commons") is not a law firm and +does not provide legal services or legal advice. Distribution of +Creative Commons public licenses does not create a lawyer-client or +other relationship. Creative Commons makes its licenses and related +information available on an "as-is" basis. Creative Commons gives no +warranties regarding its licenses, any material licensed under their +terms and conditions, or any related information. Creative Commons +disclaims all liability for damages resulting from their use to the +fullest extent possible. + +Using Creative Commons Public Licenses + +Creative Commons public licenses provide a standard set of terms and +conditions that creators and other rights holders may use to share +original works of authorship and other material subject to copyright +and certain other rights specified in the public license below. The +following considerations are for informational purposes only, are not +exhaustive, and do not form part of our licenses. + + Considerations for licensors: Our public licenses are + intended for use by those authorized to give the public + permission to use material in ways otherwise restricted by + copyright and certain other rights. Our licenses are + irrevocable. Licensors should read and understand the terms + and conditions of the license they choose before applying it. + Licensors should also secure all rights necessary before + applying our licenses so that the public can reuse the + material as expected. Licensors should clearly mark any + material not subject to the license. This includes other CC- + licensed material, or material used under an exception or + limitation to copyright. More considerations for licensors: + wiki.creativecommons.org/Considerations_for_licensors + + Considerations for the public: By using one of our public + licenses, a licensor grants the public permission to use the + licensed material under specified terms and conditions. If + the licensor's permission is not necessary for any reason--for + example, because of any applicable exception or limitation to + copyright--then that use is not regulated by the license. Our + licenses grant only permissions under copyright and certain + other rights that a licensor has authority to grant. Use of + the licensed material may still be restricted for other + reasons, including because others have copyright or other + rights in the material. A licensor may make special requests, + such as asking that all changes be marked or described. + Although not required by our licenses, you are encouraged to + respect those requests where reasonable. More_considerations + for the public: + wiki.creativecommons.org/Considerations_for_licensees + +======================================================================= + +Creative Commons Attribution 4.0 International Public License + +By exercising the Licensed Rights (defined below), You accept and agree +to be bound by the terms and conditions of this Creative Commons +Attribution 4.0 International Public License ("Public License"). To the +extent this Public License may be interpreted as a contract, You are +granted the Licensed Rights in consideration of Your acceptance of +these terms and conditions, and the Licensor grants You such rights in +consideration of benefits the Licensor receives from making the +Licensed Material available under these terms and conditions. + + +Section 1 -- Definitions. + + a. Adapted Material means material subject to Copyright and Similar + Rights that is derived from or based upon the Licensed Material + and in which the Licensed Material is translated, altered, + arranged, transformed, or otherwise modified in a manner requiring + permission under the Copyright and Similar Rights held by the + Licensor. For purposes of this Public License, where the Licensed + Material is a musical work, performance, or sound recording, + Adapted Material is always produced where the Licensed Material is + synched in timed relation with a moving image. + + b. Adapter's License means the license You apply to Your Copyright + and Similar Rights in Your contributions to Adapted Material in + accordance with the terms and conditions of this Public License. + + c. Copyright and Similar Rights means copyright and/or similar rights + closely related to copyright including, without limitation, + performance, broadcast, sound recording, and Sui Generis Database + Rights, without regard to how the rights are labeled or + categorized. For purposes of this Public License, the rights + specified in Section 2(b)(1)-(2) are not Copyright and Similar + Rights. + + d. Effective Technological Measures means those measures that, in the + absence of proper authority, may not be circumvented under laws + fulfilling obligations under Article 11 of the WIPO Copyright + Treaty adopted on December 20, 1996, and/or similar international + agreements. + + e. Exceptions and Limitations means fair use, fair dealing, and/or + any other exception or limitation to Copyright and Similar Rights + that applies to Your use of the Licensed Material. + + f. Licensed Material means the artistic or literary work, database, + or other material to which the Licensor applied this Public + License. + + g. Licensed Rights means the rights granted to You subject to the + terms and conditions of this Public License, which are limited to + all Copyright and Similar Rights that apply to Your use of the + Licensed Material and that the Licensor has authority to license. + + h. Licensor means the individual(s) or entity(ies) granting rights + under this Public License. + + i. Share means to provide material to the public by any means or + process that requires permission under the Licensed Rights, such + as reproduction, public display, public performance, distribution, + dissemination, communication, or importation, and to make material + available to the public including in ways that members of the + public may access the material from a place and at a time + individually chosen by them. + + j. Sui Generis Database Rights means rights other than copyright + resulting from Directive 96/9/EC of the European Parliament and of + the Council of 11 March 1996 on the legal protection of databases, + as amended and/or succeeded, as well as other essentially + equivalent rights anywhere in the world. + + k. You means the individual or entity exercising the Licensed Rights + under this Public License. Your has a corresponding meaning. + + +Section 2 -- Scope. + + a. License grant. + + 1. Subject to the terms and conditions of this Public License, + the Licensor hereby grants You a worldwide, royalty-free, + non-sublicensable, non-exclusive, irrevocable license to + exercise the Licensed Rights in the Licensed Material to: + + a. reproduce and Share the Licensed Material, in whole or + in part; and + + b. produce, reproduce, and Share Adapted Material. + + 2. Exceptions and Limitations. For the avoidance of doubt, where + Exceptions and Limitations apply to Your use, this Public + License does not apply, and You do not need to comply with + its terms and conditions. + + 3. Term. The term of this Public License is specified in Section + 6(a). + + 4. Media and formats; technical modifications allowed. The + Licensor authorizes You to exercise the Licensed Rights in + all media and formats whether now known or hereafter created, + and to make technical modifications necessary to do so. The + Licensor waives and/or agrees not to assert any right or + authority to forbid You from making technical modifications + necessary to exercise the Licensed Rights, including + technical modifications necessary to circumvent Effective + Technological Measures. For purposes of this Public License, + simply making modifications authorized by this Section 2(a) + (4) never produces Adapted Material. + + 5. Downstream recipients. + + a. Offer from the Licensor -- Licensed Material. Every + recipient of the Licensed Material automatically + receives an offer from the Licensor to exercise the + Licensed Rights under the terms and conditions of this + Public License. + + b. No downstream restrictions. You may not offer or impose + any additional or different terms or conditions on, or + apply any Effective Technological Measures to, the + Licensed Material if doing so restricts exercise of the + Licensed Rights by any recipient of the Licensed + Material. + + 6. No endorsement. Nothing in this Public License constitutes or + may be construed as permission to assert or imply that You + are, or that Your use of the Licensed Material is, connected + with, or sponsored, endorsed, or granted official status by, + the Licensor or others designated to receive attribution as + provided in Section 3(a)(1)(A)(i). + + b. Other rights. + + 1. Moral rights, such as the right of integrity, are not + licensed under this Public License, nor are publicity, + privacy, and/or other similar personality rights; however, to + the extent possible, the Licensor waives and/or agrees not to + assert any such rights held by the Licensor to the limited + extent necessary to allow You to exercise the Licensed + Rights, but not otherwise. + + 2. Patent and trademark rights are not licensed under this + Public License. + + 3. To the extent possible, the Licensor waives any right to + collect royalties from You for the exercise of the Licensed + Rights, whether directly or through a collecting society + under any voluntary or waivable statutory or compulsory + licensing scheme. In all other cases the Licensor expressly + reserves any right to collect such royalties. + + +Section 3 -- License Conditions. + +Your exercise of the Licensed Rights is expressly made subject to the +following conditions. + + a. Attribution. + + 1. If You Share the Licensed Material (including in modified + form), You must: + + a. retain the following if it is supplied by the Licensor + with the Licensed Material: + + i. identification of the creator(s) of the Licensed + Material and any others designated to receive + attribution, in any reasonable manner requested by + the Licensor (including by pseudonym if + designated); + + ii. a copyright notice; + + iii. a notice that refers to this Public License; + + iv. a notice that refers to the disclaimer of + warranties; + + v. a URI or hyperlink to the Licensed Material to the + extent reasonably practicable; + + b. indicate if You modified the Licensed Material and + retain an indication of any previous modifications; and + + c. indicate the Licensed Material is licensed under this + Public License, and include the text of, or the URI or + hyperlink to, this Public License. + + 2. You may satisfy the conditions in Section 3(a)(1) in any + reasonable manner based on the medium, means, and context in + which You Share the Licensed Material. For example, it may be + reasonable to satisfy the conditions by providing a URI or + hyperlink to a resource that includes the required + information. + + 3. If requested by the Licensor, You must remove any of the + information required by Section 3(a)(1)(A) to the extent + reasonably practicable. + + 4. If You Share Adapted Material You produce, the Adapter's + License You apply must not prevent recipients of the Adapted + Material from complying with this Public License. + + +Section 4 -- Sui Generis Database Rights. + +Where the Licensed Rights include Sui Generis Database Rights that +apply to Your use of the Licensed Material: + + a. for the avoidance of doubt, Section 2(a)(1) grants You the right + to extract, reuse, reproduce, and Share all or a substantial + portion of the contents of the database; + + b. if You include all or a substantial portion of the database + contents in a database in which You have Sui Generis Database + Rights, then the database in which You have Sui Generis Database + Rights (but not its individual contents) is Adapted Material; and + + c. You must comply with the conditions in Section 3(a) if You Share + all or a substantial portion of the contents of the database. + +For the avoidance of doubt, this Section 4 supplements and does not +replace Your obligations under this Public License where the Licensed +Rights include other Copyright and Similar Rights. + + +Section 5 -- Disclaimer of Warranties and Limitation of Liability. + + a. UNLESS OTHERWISE SEPARATELY UNDERTAKEN BY THE LICENSOR, TO THE + EXTENT POSSIBLE, THE LICENSOR OFFERS THE LICENSED MATERIAL AS-IS + AND AS-AVAILABLE, AND MAKES NO REPRESENTATIONS OR WARRANTIES OF + ANY KIND CONCERNING THE LICENSED MATERIAL, WHETHER EXPRESS, + IMPLIED, STATUTORY, OR OTHER. THIS INCLUDES, WITHOUT LIMITATION, + WARRANTIES OF TITLE, MERCHANTABILITY, FITNESS FOR A PARTICULAR + PURPOSE, NON-INFRINGEMENT, ABSENCE OF LATENT OR OTHER DEFECTS, + ACCURACY, OR THE PRESENCE OR ABSENCE OF ERRORS, WHETHER OR NOT + KNOWN OR DISCOVERABLE. WHERE DISCLAIMERS OF WARRANTIES ARE NOT + ALLOWED IN FULL OR IN PART, THIS DISCLAIMER MAY NOT APPLY TO YOU. + + b. TO THE EXTENT POSSIBLE, IN NO EVENT WILL THE LICENSOR BE LIABLE + TO YOU ON ANY LEGAL THEORY (INCLUDING, WITHOUT LIMITATION, + NEGLIGENCE) OR OTHERWISE FOR ANY DIRECT, SPECIAL, INDIRECT, + INCIDENTAL, CONSEQUENTIAL, PUNITIVE, EXEMPLARY, OR OTHER LOSSES, + COSTS, EXPENSES, OR DAMAGES ARISING OUT OF THIS PUBLIC LICENSE OR + USE OF THE LICENSED MATERIAL, EVEN IF THE LICENSOR HAS BEEN + ADVISED OF THE POSSIBILITY OF SUCH LOSSES, COSTS, EXPENSES, OR + DAMAGES. WHERE A LIMITATION OF LIABILITY IS NOT ALLOWED IN FULL OR + IN PART, THIS LIMITATION MAY NOT APPLY TO YOU. + + c. The disclaimer of warranties and limitation of liability provided + above shall be interpreted in a manner that, to the extent + possible, most closely approximates an absolute disclaimer and + waiver of all liability. + + +Section 6 -- Term and Termination. + + a. This Public License applies for the term of the Copyright and + Similar Rights licensed here. However, if You fail to comply with + this Public License, then Your rights under this Public License + terminate automatically. + + b. Where Your right to use the Licensed Material has terminated under + Section 6(a), it reinstates: + + 1. automatically as of the date the violation is cured, provided + it is cured within 30 days of Your discovery of the + violation; or + + 2. upon express reinstatement by the Licensor. + + For the avoidance of doubt, this Section 6(b) does not affect any + right the Licensor may have to seek remedies for Your violations + of this Public License. + + c. For the avoidance of doubt, the Licensor may also offer the + Licensed Material under separate terms or conditions or stop + distributing the Licensed Material at any time; however, doing so + will not terminate this Public License. + + d. Sections 1, 5, 6, 7, and 8 survive termination of this Public + License. + + +Section 7 -- Other Terms and Conditions. + + a. The Licensor shall not be bound by any additional or different + terms or conditions communicated by You unless expressly agreed. + + b. Any arrangements, understandings, or agreements regarding the + Licensed Material not stated herein are separate from and + independent of the terms and conditions of this Public License. + + +Section 8 -- Interpretation. + + a. For the avoidance of doubt, this Public License does not, and + shall not be interpreted to, reduce, limit, restrict, or impose + conditions on any use of the Licensed Material that could lawfully + be made without permission under this Public License. + + b. To the extent possible, if any provision of this Public License is + deemed unenforceable, it shall be automatically reformed to the + minimum extent necessary to make it enforceable. If the provision + cannot be reformed, it shall be severed from this Public License + without affecting the enforceability of the remaining terms and + conditions. + + c. No term or condition of this Public License will be waived and no + failure to comply consented to unless expressly agreed to by the + Licensor. + + d. Nothing in this Public License constitutes or may be interpreted + as a limitation upon, or waiver of, any privileges and immunities + that apply to the Licensor or You, including from the legal + processes of any jurisdiction or authority. + + +======================================================================= + +Creative Commons is not a party to its public +licenses. Notwithstanding, Creative Commons may elect to apply one of +its public licenses to material it publishes and in those instances +will be considered the “Licensor.” The text of the Creative Commons +public licenses is dedicated to the public domain under the CC0 Public +Domain Dedication. Except for the limited purpose of indicating that +material is shared under a Creative Commons public license or as +otherwise permitted by the Creative Commons policies published at +creativecommons.org/policies, Creative Commons does not authorize the +use of the trademark "Creative Commons" or any other trademark or logo +of Creative Commons without its prior written consent including, +without limitation, in connection with any unauthorized modifications +to any of its public licenses or any other arrangements, +understandings, or agreements concerning use of licensed material. For +the avoidance of doubt, this paragraph does not form part of the +public licenses. + +Creative Commons may be contacted at creativecommons.org. \ No newline at end of file diff --git a/lisp/company/icons/attribution.md b/lisp/company/icons/attribution.md new file mode 100644 index 00000000..33513fc7 --- /dev/null +++ b/lisp/company/icons/attribution.md @@ -0,0 +1,5 @@ +The icons in this directory have been made by "Microsoft and any contributors", +see the [development repository](https://github.com/microsoft/vscode-icons/). + +They are distributed under Creative Commons Attribution 4.0 International Public +License, see the LICENSE file in this directory. diff --git a/lisp/company/icons/vscode-dark/folder.svg b/lisp/company/icons/vscode-dark/folder.svg new file mode 100644 index 00000000..7387525e --- /dev/null +++ b/lisp/company/icons/vscode-dark/folder.svg @@ -0,0 +1,3 @@ + + + \ No newline at end of file diff --git a/lisp/company/icons/vscode-dark/references.svg b/lisp/company/icons/vscode-dark/references.svg new file mode 100644 index 00000000..9e4c78e3 --- /dev/null +++ b/lisp/company/icons/vscode-dark/references.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-dark/symbol-array.svg b/lisp/company/icons/vscode-dark/symbol-array.svg new file mode 100644 index 00000000..e92131d3 --- /dev/null +++ b/lisp/company/icons/vscode-dark/symbol-array.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-dark/symbol-boolean.svg b/lisp/company/icons/vscode-dark/symbol-boolean.svg new file mode 100644 index 00000000..e009568b --- /dev/null +++ b/lisp/company/icons/vscode-dark/symbol-boolean.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-dark/symbol-class.svg b/lisp/company/icons/vscode-dark/symbol-class.svg new file mode 100644 index 00000000..b35a6bb3 --- /dev/null +++ b/lisp/company/icons/vscode-dark/symbol-class.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-dark/symbol-color.svg b/lisp/company/icons/vscode-dark/symbol-color.svg new file mode 100644 index 00000000..91469f94 --- /dev/null +++ b/lisp/company/icons/vscode-dark/symbol-color.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-dark/symbol-constant.svg b/lisp/company/icons/vscode-dark/symbol-constant.svg new file mode 100644 index 00000000..0e90ecaf --- /dev/null +++ b/lisp/company/icons/vscode-dark/symbol-constant.svg @@ -0,0 +1,4 @@ + + + + diff --git a/lisp/company/icons/vscode-dark/symbol-enumerator-member.svg b/lisp/company/icons/vscode-dark/symbol-enumerator-member.svg new file mode 100644 index 00000000..53735c15 --- /dev/null +++ b/lisp/company/icons/vscode-dark/symbol-enumerator-member.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-dark/symbol-enumerator.svg b/lisp/company/icons/vscode-dark/symbol-enumerator.svg new file mode 100644 index 00000000..2197f668 --- /dev/null +++ b/lisp/company/icons/vscode-dark/symbol-enumerator.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-dark/symbol-event.svg b/lisp/company/icons/vscode-dark/symbol-event.svg new file mode 100644 index 00000000..051bef31 --- /dev/null +++ b/lisp/company/icons/vscode-dark/symbol-event.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-dark/symbol-field.svg b/lisp/company/icons/vscode-dark/symbol-field.svg new file mode 100644 index 00000000..f7b9e28a --- /dev/null +++ b/lisp/company/icons/vscode-dark/symbol-field.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-dark/symbol-file.svg b/lisp/company/icons/vscode-dark/symbol-file.svg new file mode 100644 index 00000000..c9b6a03f --- /dev/null +++ b/lisp/company/icons/vscode-dark/symbol-file.svg @@ -0,0 +1,3 @@ + + + \ No newline at end of file diff --git a/lisp/company/icons/vscode-dark/symbol-interface.svg b/lisp/company/icons/vscode-dark/symbol-interface.svg new file mode 100644 index 00000000..b8ff0abe --- /dev/null +++ b/lisp/company/icons/vscode-dark/symbol-interface.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-dark/symbol-key.svg b/lisp/company/icons/vscode-dark/symbol-key.svg new file mode 100644 index 00000000..80fb9d65 --- /dev/null +++ b/lisp/company/icons/vscode-dark/symbol-key.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-dark/symbol-keyword.svg b/lisp/company/icons/vscode-dark/symbol-keyword.svg new file mode 100644 index 00000000..70ba6ea9 --- /dev/null +++ b/lisp/company/icons/vscode-dark/symbol-keyword.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-dark/symbol-method.svg b/lisp/company/icons/vscode-dark/symbol-method.svg new file mode 100644 index 00000000..cccf5a06 --- /dev/null +++ b/lisp/company/icons/vscode-dark/symbol-method.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-dark/symbol-misc.svg b/lisp/company/icons/vscode-dark/symbol-misc.svg new file mode 100644 index 00000000..88809238 --- /dev/null +++ b/lisp/company/icons/vscode-dark/symbol-misc.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-dark/symbol-namespace.svg b/lisp/company/icons/vscode-dark/symbol-namespace.svg new file mode 100644 index 00000000..9a725bb4 --- /dev/null +++ b/lisp/company/icons/vscode-dark/symbol-namespace.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-dark/symbol-numeric.svg b/lisp/company/icons/vscode-dark/symbol-numeric.svg new file mode 100644 index 00000000..a1573df0 --- /dev/null +++ b/lisp/company/icons/vscode-dark/symbol-numeric.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-dark/symbol-operator.svg b/lisp/company/icons/vscode-dark/symbol-operator.svg new file mode 100644 index 00000000..957f5f44 --- /dev/null +++ b/lisp/company/icons/vscode-dark/symbol-operator.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-dark/symbol-parameter.svg b/lisp/company/icons/vscode-dark/symbol-parameter.svg new file mode 100644 index 00000000..425ced36 --- /dev/null +++ b/lisp/company/icons/vscode-dark/symbol-parameter.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-dark/symbol-property.svg b/lisp/company/icons/vscode-dark/symbol-property.svg new file mode 100644 index 00000000..7137a9d7 --- /dev/null +++ b/lisp/company/icons/vscode-dark/symbol-property.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-dark/symbol-ruler.svg b/lisp/company/icons/vscode-dark/symbol-ruler.svg new file mode 100644 index 00000000..1957dbad --- /dev/null +++ b/lisp/company/icons/vscode-dark/symbol-ruler.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-dark/symbol-snippet.svg b/lisp/company/icons/vscode-dark/symbol-snippet.svg new file mode 100644 index 00000000..79799f98 --- /dev/null +++ b/lisp/company/icons/vscode-dark/symbol-snippet.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-dark/symbol-string.svg b/lisp/company/icons/vscode-dark/symbol-string.svg new file mode 100644 index 00000000..ef5f2265 --- /dev/null +++ b/lisp/company/icons/vscode-dark/symbol-string.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-dark/symbol-structure.svg b/lisp/company/icons/vscode-dark/symbol-structure.svg new file mode 100644 index 00000000..13766a5d --- /dev/null +++ b/lisp/company/icons/vscode-dark/symbol-structure.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-dark/symbol-variable.svg b/lisp/company/icons/vscode-dark/symbol-variable.svg new file mode 100644 index 00000000..5ee50e0e --- /dev/null +++ b/lisp/company/icons/vscode-dark/symbol-variable.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-light/folder.svg b/lisp/company/icons/vscode-light/folder.svg new file mode 100644 index 00000000..c0939fe2 --- /dev/null +++ b/lisp/company/icons/vscode-light/folder.svg @@ -0,0 +1,3 @@ + + + \ No newline at end of file diff --git a/lisp/company/icons/vscode-light/references.svg b/lisp/company/icons/vscode-light/references.svg new file mode 100644 index 00000000..eea62e06 --- /dev/null +++ b/lisp/company/icons/vscode-light/references.svg @@ -0,0 +1,10 @@ + + + + + + + + + + diff --git a/lisp/company/icons/vscode-light/symbol-array.svg b/lisp/company/icons/vscode-light/symbol-array.svg new file mode 100644 index 00000000..9d7a3889 --- /dev/null +++ b/lisp/company/icons/vscode-light/symbol-array.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-light/symbol-boolean.svg b/lisp/company/icons/vscode-light/symbol-boolean.svg new file mode 100644 index 00000000..8cee69d0 --- /dev/null +++ b/lisp/company/icons/vscode-light/symbol-boolean.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-light/symbol-class.svg b/lisp/company/icons/vscode-light/symbol-class.svg new file mode 100644 index 00000000..7b0c2b95 --- /dev/null +++ b/lisp/company/icons/vscode-light/symbol-class.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-light/symbol-color.svg b/lisp/company/icons/vscode-light/symbol-color.svg new file mode 100644 index 00000000..a67efd3a --- /dev/null +++ b/lisp/company/icons/vscode-light/symbol-color.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-light/symbol-constant.svg b/lisp/company/icons/vscode-light/symbol-constant.svg new file mode 100644 index 00000000..5f185bc5 --- /dev/null +++ b/lisp/company/icons/vscode-light/symbol-constant.svg @@ -0,0 +1,4 @@ + + + + diff --git a/lisp/company/icons/vscode-light/symbol-enumerator-member.svg b/lisp/company/icons/vscode-light/symbol-enumerator-member.svg new file mode 100644 index 00000000..31d16543 --- /dev/null +++ b/lisp/company/icons/vscode-light/symbol-enumerator-member.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-light/symbol-enumerator.svg b/lisp/company/icons/vscode-light/symbol-enumerator.svg new file mode 100644 index 00000000..dbbc5fd5 --- /dev/null +++ b/lisp/company/icons/vscode-light/symbol-enumerator.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-light/symbol-event.svg b/lisp/company/icons/vscode-light/symbol-event.svg new file mode 100644 index 00000000..31e574b1 --- /dev/null +++ b/lisp/company/icons/vscode-light/symbol-event.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-light/symbol-field.svg b/lisp/company/icons/vscode-light/symbol-field.svg new file mode 100644 index 00000000..5151b2a4 --- /dev/null +++ b/lisp/company/icons/vscode-light/symbol-field.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-light/symbol-file.svg b/lisp/company/icons/vscode-light/symbol-file.svg new file mode 100644 index 00000000..781e39e1 --- /dev/null +++ b/lisp/company/icons/vscode-light/symbol-file.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-light/symbol-interface.svg b/lisp/company/icons/vscode-light/symbol-interface.svg new file mode 100644 index 00000000..3b83725c --- /dev/null +++ b/lisp/company/icons/vscode-light/symbol-interface.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-light/symbol-key.svg b/lisp/company/icons/vscode-light/symbol-key.svg new file mode 100644 index 00000000..6af4c1aa --- /dev/null +++ b/lisp/company/icons/vscode-light/symbol-key.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-light/symbol-keyword.svg b/lisp/company/icons/vscode-light/symbol-keyword.svg new file mode 100644 index 00000000..e0400646 --- /dev/null +++ b/lisp/company/icons/vscode-light/symbol-keyword.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-light/symbol-method.svg b/lisp/company/icons/vscode-light/symbol-method.svg new file mode 100644 index 00000000..f922a9a9 --- /dev/null +++ b/lisp/company/icons/vscode-light/symbol-method.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-light/symbol-misc.svg b/lisp/company/icons/vscode-light/symbol-misc.svg new file mode 100644 index 00000000..57467b3c --- /dev/null +++ b/lisp/company/icons/vscode-light/symbol-misc.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-light/symbol-namespace.svg b/lisp/company/icons/vscode-light/symbol-namespace.svg new file mode 100644 index 00000000..8d1c0f4a --- /dev/null +++ b/lisp/company/icons/vscode-light/symbol-namespace.svg @@ -0,0 +1,10 @@ + + + + + + + + + + diff --git a/lisp/company/icons/vscode-light/symbol-numeric.svg b/lisp/company/icons/vscode-light/symbol-numeric.svg new file mode 100644 index 00000000..0ab24fa9 --- /dev/null +++ b/lisp/company/icons/vscode-light/symbol-numeric.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-light/symbol-operator.svg b/lisp/company/icons/vscode-light/symbol-operator.svg new file mode 100644 index 00000000..23d0d199 --- /dev/null +++ b/lisp/company/icons/vscode-light/symbol-operator.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-light/symbol-parameter.svg b/lisp/company/icons/vscode-light/symbol-parameter.svg new file mode 100644 index 00000000..940524db --- /dev/null +++ b/lisp/company/icons/vscode-light/symbol-parameter.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-light/symbol-property.svg b/lisp/company/icons/vscode-light/symbol-property.svg new file mode 100644 index 00000000..efffad48 --- /dev/null +++ b/lisp/company/icons/vscode-light/symbol-property.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-light/symbol-ruler.svg b/lisp/company/icons/vscode-light/symbol-ruler.svg new file mode 100644 index 00000000..0a0b9a4e --- /dev/null +++ b/lisp/company/icons/vscode-light/symbol-ruler.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-light/symbol-snippet.svg b/lisp/company/icons/vscode-light/symbol-snippet.svg new file mode 100644 index 00000000..ebb8a11f --- /dev/null +++ b/lisp/company/icons/vscode-light/symbol-snippet.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-light/symbol-string.svg b/lisp/company/icons/vscode-light/symbol-string.svg new file mode 100644 index 00000000..2fabca57 --- /dev/null +++ b/lisp/company/icons/vscode-light/symbol-string.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-light/symbol-structure.svg b/lisp/company/icons/vscode-light/symbol-structure.svg new file mode 100644 index 00000000..2b8c0d95 --- /dev/null +++ b/lisp/company/icons/vscode-light/symbol-structure.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/company/icons/vscode-light/symbol-variable.svg b/lisp/company/icons/vscode-light/symbol-variable.svg new file mode 100644 index 00000000..3656d9e1 --- /dev/null +++ b/lisp/company/icons/vscode-light/symbol-variable.svg @@ -0,0 +1,3 @@ + + + diff --git a/lisp/counsel.el b/lisp/counsel.el index 27652348..e7ef5139 100644 --- a/lisp/counsel.el +++ b/lisp/counsel.el @@ -1,13 +1,13 @@ ;;; counsel.el --- Various completion functions using Ivy -*- lexical-binding: t -*- -;; Copyright (C) 2015-2019 Free Software Foundation, Inc. +;; Copyright (C) 2015-2021 Free Software Foundation, Inc. ;; Author: Oleh Krehel ;; URL: https://github.com/abo-abo/swiper -;; Package-Version: 20201227.1327 -;; Package-Commit: 71c59aecf669142ebe264fac8ff7b440c0c71712 -;; Version: 0.13.0 -;; Package-Requires: ((emacs "24.5") (swiper "0.13.0")) +;; Package-Version: 20211230.1909 +;; Package-Commit: c97ea72285f2428ed61b519269274d27f2b695f9 +;; Version: 0.13.4 +;; Package-Requires: ((emacs "24.5") (ivy "0.13.4") (swiper "0.13.4")) ;; Keywords: convenience, matching, tools ;; This file is part of GNU Emacs. @@ -42,6 +42,7 @@ ;;; Code: +(require 'ivy) (require 'swiper) (require 'compile) @@ -124,10 +125,11 @@ complex regexes." (executable-find command))) "Compatibility shim for `executable-find'.") -(defun counsel-require-program (cmd) +(defun counsel-require-program (cmd &optional noerror) "Check system for program used in CMD, printing error if not found. CMD is either a string or a list of strings. -To skip the `executable-find' check, start the string with a space." +To skip the `executable-find' check, start the string with a space. +When NOERROR is non-nil, return nil instead of raising an error." (unless (and (stringp cmd) (string-prefix-p " " cmd)) (let ((program (if (listp cmd) (car cmd) @@ -135,7 +137,8 @@ To skip the `executable-find' check, start the string with a space." (or (and (stringp program) (not (string= program "")) (counsel--executable-find program t)) - (user-error "Required program \"%s\" not found in your path" program))))) + (unless noerror + (user-error "Required program \"%s\" not found in your path" program)))))) (declare-function eshell-split-path "esh-util") @@ -424,7 +427,8 @@ Update the minibuffer with the amount of lines collected every (cons (concat (car x) (irony-completion-annotation x)) (car x))) -(add-to-list 'ivy-display-functions-alist '(counsel-irony . ivy-display-function-overlay)) +(ivy-configure #'counsel-irony + :display-fn #'ivy-display-function-overlay) ;;* Elisp symbols ;;** `counsel-describe-variable' @@ -622,29 +626,35 @@ to `ivy-highlight-face'." (defun counsel-read-setq-expression (sym) "Read and eval a setq expression for SYM." (setq this-command 'eval-expression) - (let* ((minibuffer-completing-symbol t) - (sym-value (symbol-value sym)) - (expr (minibuffer-with-setup-hook - (lambda () - ;; Functions `elisp-eldoc-documentation-function' and - ;; `elisp-completion-at-point' added in Emacs 25.1. - (add-function :before-until (local 'eldoc-documentation-function) - #'elisp-eldoc-documentation-function) - (add-hook 'completion-at-point-functions #'elisp-completion-at-point nil t) - (run-hooks 'eval-expression-minibuffer-setup-hook) - (goto-char (minibuffer-prompt-end)) - (forward-char 6) - (insert (format "%S " sym))) - (read-from-minibuffer "Eval: " - (format - (if (and sym-value (or (consp sym-value) - (symbolp sym-value))) - "(setq '%S)" - "(setq %S)") - sym-value) - read-expression-map t - 'read-expression-history)))) - expr)) + (let* ((sym-value (symbol-value sym)) + (init (format "(setq %s%S)" + (if (or (consp sym-value) + (and sym-value (symbolp sym-value))) + "'" + "") + sym-value))) + ;; Most of this duplicates `read--expression'. + (minibuffer-with-setup-hook + (lambda () + (set-syntax-table emacs-lisp-mode-syntax-table) + ;; Added in Emacs 25.1. + (when (fboundp 'elisp-completion-at-point) + (add-hook 'completion-at-point-functions + #'elisp-completion-at-point nil t)) + ;; Emacs 27+ already sets up ElDoc in this hook. Emacs 25 added + ;; `elisp-eldoc-documentation-function' and Emacs 28 obsoletes it. + (when (< emacs-major-version 27) + (when (fboundp 'elisp-eldoc-documentation-function) + (add-function :before-until (local 'eldoc-documentation-function) + #'elisp-eldoc-documentation-function)) + (eldoc-mode)) + (run-hooks 'eval-expression-minibuffer-setup-hook) + ;; The following diverges from `read--expression'. + (goto-char (minibuffer-prompt-end)) + (forward-char 6) + (insert (format "%S " sym))) + (read-from-minibuffer "Eval: " init read-expression-map t + 'read-expression-history)))) (defun counsel--setq-doconst (x) "Return a cons of description and value for X. @@ -875,6 +885,26 @@ packages are, in order of precedence, `amx' and `smex'." (smex-update)) smex-ido-cache))) +(defun counsel--M-x-externs-predicate (cand) + "Return non-nil if `counsel-M-x' should complete CAND. +CAND is a string returned by `counsel--M-x-externs'." + (not (get (intern cand) 'no-counsel-M-x))) + +(defun counsel--M-x-make-predicate () + "Return a predicate for `counsel-M-x' in the current buffer." + (defvar read-extended-command-predicate) + (let ((buf (current-buffer))) + (lambda (sym) + (and (commandp sym) + (not (get sym 'byte-obsolete-info)) + (not (get sym 'no-counsel-M-x)) + (cond ((not (bound-and-true-p read-extended-command-predicate))) + ((functionp read-extended-command-predicate) + (condition-case-unless-debug err + (funcall read-extended-command-predicate sym buf) + (error (message "read-extended-command-predicate: %s: %s" + sym (error-message-string err)))))))))) + (defun counsel--M-x-prompt () "String for `M-x' plus the string representation of `current-prefix-arg'." (concat (cond ((null current-prefix-arg) @@ -920,12 +950,8 @@ when available, in that order of precedence." (let ((externs (counsel--M-x-externs))) (ivy-read (counsel--M-x-prompt) (or externs obarray) :predicate (if externs - (lambda (x) - (not (get (intern x) 'no-counsel-M-x))) - (lambda (sym) - (and (commandp sym) - (not (get sym 'byte-obsolete-info)) - (not (get sym 'no-counsel-M-x))))) + #'counsel--M-x-externs-predicate + (counsel--M-x-make-predicate)) :require-match t :history 'counsel-M-x-history :action #'counsel-M-x-action @@ -1818,7 +1844,7 @@ currently checked out." "Switch to `counsel-file-jump' from `counsel-find-file'." (interactive) (ivy-quit-and-run - (counsel-file-jump ivy-text))) + (counsel-file-jump ivy-text (ivy-state-directory ivy-last)))) (when (executable-find "git") (add-to-list 'ivy-ffap-url-functions 'counsel-github-url-p) @@ -1947,7 +1973,7 @@ but the leading dot is a lot faster." (const :tag "None" nil) (const :tag "Dotfiles and Lockfiles" "\\(?:\\`\\|[/\\]\\)\\(?:[#.]\\)") (const :tag "Ignored Extensions" - ,(regexp-opt completion-ignored-extensions)) + ,(concat (regexp-opt completion-ignored-extensions) "\\'")) (regexp :tag "Regex"))) (defvar counsel--find-file-predicate nil @@ -2028,14 +2054,15 @@ The preselect behavior can be customized via user options :caller caller))) ;;;###autoload -(defun counsel-find-file (&optional initial-input) +(defun counsel-find-file (&optional initial-input initial-directory) "Forward to `find-file'. When INITIAL-INPUT is non-nil, use it in the minibuffer during completion." (interactive) - (counsel--find-file-1 - "Find file: " initial-input - #'counsel-find-file-action - 'counsel-find-file)) + (let ((tramp-archive-enabled nil) + (default-directory (or initial-directory default-directory))) + (counsel--find-file-1 "Find file: " initial-input + #'counsel-find-file-action + 'counsel-find-file))) (ivy-configure 'counsel-find-file :parent 'read-file-name-internal @@ -2188,34 +2215,34 @@ See variable `counsel-up-directory-level'." (defun counsel-github-url-p () "Return a Github issue URL at point." - (counsel-require-program "git") - (let ((url (counsel-at-git-issue-p))) - (when url - (let ((origin (shell-command-to-string - "git remote get-url origin")) - user repo) - (cond ((string-match "\\`git@github.com:\\([^/]+\\)/\\(.*\\)\\.git$" - origin) - (setq user (match-string 1 origin)) - (setq repo (match-string 2 origin))) - ((string-match "\\`https://github.com/\\([^/]+\\)/\\(.*\\)$" - origin) - (setq user (match-string 1 origin)) - (setq repo (match-string 2 origin)))) - (when user - (setq url (format "https://github.com/%s/%s/issues/%s" - user repo (substring url 1)))))))) + (when (counsel-require-program "git" t) + (let ((url (counsel-at-git-issue-p))) + (when url + (let ((origin (shell-command-to-string + "git remote get-url origin")) + user repo) + (cond ((string-match "\\`git@github.com:\\([^/]+\\)/\\(.*\\)\\.git$" + origin) + (setq user (match-string 1 origin)) + (setq repo (match-string 2 origin))) + ((string-match "\\`https://github.com/\\([^/]+\\)/\\(.*\\)$" + origin) + (setq user (match-string 1 origin)) + (setq repo (match-string 2 origin)))) + (when user + (setq url (format "https://github.com/%s/%s/issues/%s" + user repo (substring url 1))))))))) (defun counsel-emacs-url-p () "Return a Debbugs issue URL at point." - (counsel-require-program "git") - (let ((url (counsel-at-git-issue-p))) - (when url - (let ((origin (shell-command-to-string - "git remote get-url origin"))) - (when (string-match "git.sv.gnu.org:/srv/git/emacs.git" origin) - (format "https://debbugs.gnu.org/cgi/bugreport.cgi?bug=%s" - (substring url 1))))))) + (when (counsel-require-program "git" t) + (let ((url (counsel-at-git-issue-p))) + (when url + (let ((origin (shell-command-to-string + "git remote get-url origin"))) + (when (string-match "git.sv.gnu.org:/srv/git/emacs.git" origin) + (format "https://debbugs.gnu.org/cgi/bugreport.cgi?bug=%s" + (substring url 1)))))))) (defvar counsel-url-expansions-alist nil "Map of regular expressions to expansions. @@ -2466,7 +2493,8 @@ By default `counsel-bookmark' opens a dired buffer for directories." (ivy-set-actions 'counsel-bookmark - `(("d" bookmark-delete "delete") + `(("j" bookmark-jump-other-window "other window") + ("d" bookmark-delete "delete") ("e" bookmark-rename "edit") ("s" bookmark-set "overwrite") ("x" ,(counsel--apply-bookmark-fn #'counsel-find-file-extern) @@ -2593,18 +2621,27 @@ string - the full shell command to run." "Use `dired-jump' on X." (dired-jump nil x)) +(defvar locate-command) + (defun counsel-locate-cmd-default (input) - "Return a `locate' shell command based on regexp INPUT." - (counsel-require-program "locate") - (format "locate -i --regex %s" + "Return a `locate' shell command based on regexp INPUT. +This uses the user option `locate-command' from the `locate' +library, which see." + (counsel-require-program locate-command) + (format "%s -i --regex %s" + locate-command (shell-quote-argument (counsel--elisp-to-pcre (ivy--regex input))))) (defun counsel-locate-cmd-noregex (input) - "Return a `locate' shell command based on INPUT." - (counsel-require-program "locate") - (format "locate -i %s" (shell-quote-argument input))) + "Return a `locate' shell command based on INPUT. +This uses the user option `locate-command' from the `locate' +library, which see." + (counsel-require-program locate-command) + (format "%s -i %s" + locate-command + (shell-quote-argument input))) (defun counsel-locate-cmd-mdfind (input) "Return a `mdfind' shell command based on INPUT." @@ -2660,6 +2697,8 @@ string - the full shell command to run." "Call a \"locate\" style shell command. INITIAL-INPUT can be given as the initial minibuffer input." (interactive) + ;; For `locate-command', which is honored in some options of `counsel-locate-cmd'. + (require 'locate) (counsel--locate-updatedb) (ivy-read "Locate: " #'counsel-locate-function :initial-input initial-input @@ -2843,6 +2882,18 @@ FZF-PROMPT, if non-nil, is passed as `ivy-read' prompt argument." :type '(repeat string)) ;;** `counsel-file-jump' +(defvar counsel-file-jump-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "`") #'counsel-find-file-from-jump) + map) + "Key bindings to be used when in a file-jump minibuffer.") + +(defun counsel-find-file-from-jump () + "Switch to `counsel-find-file' from `counsel-file-jump'." + (interactive) + (ivy-quit-and-run + (counsel-find-file ivy-text (ivy-state-directory ivy-last)))) + ;;;###autoload (defun counsel-file-jump (&optional initial-input initial-directory) "Jump to a file below the current directory. @@ -2863,6 +2914,7 @@ INITIAL-DIRECTORY, if non-nil, is used as the root directory for search." :preselect (counsel--preselect-file) :require-match 'confirm-after-completion :history 'file-name-history + :keymap counsel-file-jump-map :caller 'counsel-file-jump))) (ivy-set-actions @@ -2908,14 +2960,24 @@ INITIAL-DIRECTORY, if non-nil, is used as the root directory for search." (define-key map (kbd "C-x C-d") 'counsel-cd) map)) -(defcustom counsel-ag-base-command "ag --vimgrep %s" - "Format string to use in `counsel-ag-function' to construct the command. -The %s will be replaced by optional extra ag arguments followed by the -regex string." - :type '(radio - (const "ag --vimgrep %s") - (const "ag --nocolor --nogroup %s") - (string :tag "custom"))) +(defcustom counsel-ag-base-command (list "ag" "--vimgrep" "%s") + "Template for default `counsel-ag' command. +The value should be either a list of strings, starting with the +`ag' executable file name and followed by its arguments, or a +single string describing a full `ag' shell command. + +If the command is specified as a list, `ag' is called directly +using `process-file'; otherwise, it is called as a shell command. +Calling `ag' directly avoids various shell quoting pitfalls, so +it is generally recommended. + +If the string \"%s\" appears as an element of the list, or as a +substring of the command string, it is replaced by any optional +`ag' arguments followed by the search regexp specified during the +`counsel-ag' session." + :package-version '(counsel . "0.14.0") + :type '(choice (repeat :tag "Command list to call directly" string) + (string :tag "Shell command"))) (defvar counsel-ag-command nil) @@ -2973,11 +3035,11 @@ NEEDLE is the search string." (ivy-more-chars)) (let* ((default-directory (ivy-state-directory ivy-last)) (regex (counsel--grep-regex search-term)) - (switches (concat (car command-args) - (counsel--ag-extra-switches regex) - (if (ivy--case-fold-p string) + (switches (concat (if (ivy--case-fold-p string) " -i " - " -s ")))) + " -s ") + (counsel--ag-extra-switches regex) + (car command-args)))) (counsel--async-command (counsel--format-ag-command switches (funcall (if (listp counsel-ag-command) #'identity @@ -2988,9 +3050,10 @@ NEEDLE is the search string." ;;;###autoload (cl-defun counsel-ag (&optional initial-input initial-directory extra-ag-args ag-prompt &key caller) - "Grep for a string in a root directory using ag. + "Grep for a string in a root directory using `ag'. -By default, the root directory is the first directory containing a .git subdirectory. +By default, the root directory is the first directory containing +a .git subdirectory. INITIAL-INPUT can be given as the initial minibuffer input. INITIAL-DIRECTORY, if non-nil, is used as the root directory for search. @@ -3041,7 +3104,9 @@ prompt additionally for EXTRA-AG-ARGS." :exit-codes '(1 "No matches found")) (defun counsel-read-directory-name (prompt &optional default) - "Read a directory name from user, a (partial) replacement of `read-directory-name'." + "Read a directory name. +This is intended as a (partial) replacement for +`read-directory-name'." (let ((counsel--find-file-predicate #'file-directory-p)) (ivy-read prompt #'read-file-name-internal @@ -3080,8 +3145,9 @@ Works for `counsel-git-grep', `counsel-ag', etc." (ivy-occur-grep-mode) (setq default-directory (ivy-state-directory ivy-last))) (ivy-set-text - (and (string-match "\"\\(.*\\)\"" (buffer-name)) - (match-string 1 (buffer-name)))) + (if (string-match "\"\\(.*\\)\"" (buffer-name)) + (match-string 1 (buffer-name)) + (ivy-state-text ivy-occur-last))) (let* ((cmd (if (functionp cmd-template) (funcall cmd-template ivy-text) @@ -3157,19 +3223,23 @@ This uses `counsel-ag' with `counsel-ack-base-command' replacing initial-input nil nil nil :caller 'counsel-ack))) - ;;** `counsel-rg' (defcustom counsel-rg-base-command - (split-string - (if (memq system-type '(ms-dos windows-nt)) - "rg -M 240 --with-filename --no-heading --line-number --color never %s --path-separator / ." - "rg -M 240 --with-filename --no-heading --line-number --color never %s")) - "Alternative to `counsel-ag-base-command' using ripgrep. + `("rg" + "--max-columns" "240" + "--with-filename" + "--no-heading" + "--line-number" + "--color" "never" + "%s" + ,@(and (memq system-type '(ms-dos windows-nt)) + (list "--path-separator" "/" "."))) + "Like `counsel-ag-base-command', but for `counsel-rg'. -Note: don't use single quotes for the regex." - :type '(choice - (repeat :tag "List to be used in `process-file'." string) - (string :tag "String to be used in `shell-command-to-string'."))) +Note: don't use single quotes for the regexp." + :package-version '(counsel . "0.14.0") + :type '(choice (repeat :tag "Command list to call directly" string) + (string :tag "Shell command"))) (defun counsel--rg-targets () "Return a list of files to operate on, based on `dired-mode' marks." @@ -3186,7 +3256,7 @@ Note: don't use single quotes for the regex." ;;;###autoload (defun counsel-rg (&optional initial-input initial-directory extra-rg-args rg-prompt) - "Grep for a string in the current directory using rg. + "Grep for a string in the current directory using `rg'. INITIAL-INPUT can be given as the initial minibuffer input. INITIAL-DIRECTORY, if non-nil, is used as the root directory for search. EXTRA-RG-ARGS string, if non-nil, is appended to `counsel-rg-base-command'. @@ -4522,6 +4592,8 @@ Note: Duplicate elements of `kill-ring' are always deleted." :action #'counsel-yank-pop-action :caller 'counsel-yank-pop))) +(put #'counsel-yank-pop 'delete-selection 'yank) + (ivy-configure 'counsel-yank-pop :height 5 :format-fn #'counsel--yank-pop-format-function) @@ -4764,6 +4836,7 @@ An extra action allows to switch to the process buffer." (ivy-read "History: " (ivy-history-contents minibuffer-history-variable) :keymap ivy-reverse-i-search-map :action (lambda (x) + (delete-minibuffer-contents) (insert (substring-no-properties (car x)))) :caller 'counsel-minibuffer-history))) @@ -5188,7 +5261,7 @@ the face to apply." NAME specifies the name of the buffer (defaults to \"*Ibuffer*\")." (interactive) (setq counsel-ibuffer--buffer-name (or name "*Ibuffer*")) - (ivy-read "Switch to buffer: " (counsel-ibuffer--get-buffers) + (ivy-read "Switch to buffer: " (counsel--ibuffer-get-buffers) :history 'counsel-ibuffer-history :action #'counsel-ibuffer-visit-buffer :caller 'counsel-ibuffer)) @@ -5198,8 +5271,10 @@ NAME specifies the name of the buffer (defaults to \"*Ibuffer*\")." (declare-function ibuffer-forward-line "ibuffer") (defvar ibuffer-movement-cycle) -(defun counsel-ibuffer--get-buffers () - "Return list of buffer-related lines in Ibuffer as strings." +(defun counsel--ibuffer-get-buffers () + "Return an alist with buffer completion candidates from Ibuffer. +The keys are buffer-related lines from Ibuffer as strings, and +the values are the corresponding buffer objects." (let ((oldbuf (get-buffer counsel-ibuffer--buffer-name))) (unless oldbuf ;; Avoid messing with the user's precious window/frame configuration. @@ -5229,11 +5304,11 @@ NAME specifies the name of the buffer (defaults to \"*Ibuffer*\")." (defun counsel-ibuffer-visit-buffer (x) "Switch to buffer of candidate X." - (switch-to-buffer (cdr x))) + (switch-to-buffer (or (cdr-safe x) x))) (defun counsel-ibuffer-visit-buffer-other-window (x) "Switch to buffer of candidate X in another window." - (switch-to-buffer-other-window (cdr x))) + (switch-to-buffer-other-window (or (cdr-safe x) x))) (defun counsel-ibuffer-visit-ibuffer (_) "Switch to Ibuffer buffer." @@ -5398,6 +5473,9 @@ Return nil if NAME does not designate a valid color." 'face (list :foreground fg :background hex)))) formatter colors "\n"))) +;; No longer preloaded in Emacs 28. +(autoload 'list-colors-duplicates "facemenu") + ;;;###autoload (defun counsel-colors-emacs () "Show a list of all supported colors for a particular frame. @@ -5566,8 +5644,9 @@ value of a macro, using them for a new macro." (defun counsel--kmacro-candidates () "Create the list of keyboard macros used by `counsel-kmacro'. -This is a combination of `kmacro-ring' and, together in a list, `last-kbd-macro', -`kmacro-counter-format-start', and `kmacro-counter-value-start'." +This is a combination of `kmacro-ring' and, together in a list, +`last-kbd-macro', `kmacro-counter-format-start', and +`kmacro-counter-value-start'." (mapcar (lambda (kmacro) (cons @@ -5628,7 +5707,10 @@ to 0." (kmacro-set-counter number))) (defun counsel-kmacro-action-copy-counter-format-for-new-macro (x) - "Set `kmacro-default-counter-format' to an existing keyboard macro's counter format. + "Set the default keyboard macro counter format. +This sets `kmacro-default-counter-format' to the counter format +of an existing keyboard macro. + This will apply to the next macro a user defines." (let* ((actual-kmacro (cdr x)) (format (nth 2 actual-kmacro))) diff --git a/lisp/crdt.el b/lisp/crdt.el index c2d5fd50..001f5177 100644 --- a/lisp/crdt.el +++ b/lisp/crdt.el @@ -1,24 +1,27 @@ -;;; crdt.el --- collaborative editing using Conflict-free Replicated Data Types -*- lexical-binding: t; -*- -;; -;; Copyright (C) 2020 Qiantan Hong -;; -;; Author: Qiantan Hong -;; Maintainer: Qiantan Hong +;;; crdt.el --- Collaborative editing using Conflict-free Replicated Data Types -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; Author: Qiantan Hong +;; Maintainer: Qiantan Hong +;; URL: https://code.librehq.com/qhong/crdt.el ;; Keywords: collaboration crdt -;; Version: 0.0.0 -;; -;; crdt.el is free software: you can redistribute it and/or modify +;; Version: 0.2.7 + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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. -;; -;; crdt.el is distributed in the hope that it will be useful, + +;; GNU Emacs 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 crdt.el. If not, see . +;; along with GNU Emacs. If not, see . ;;; Commentary: ;; This package provides a collaborative editing environment for Emacs. @@ -27,6 +30,19 @@ ;;; Customs +(require 'xdg nil t) +(require 'cl-lib) +(require 'url) +(require 'color) + +(defconst crdt-version "0.2.7") +(defconst crdt-protocol-version "0.2.5") + +(defun crdt-version () + "Show the crdt.el version." + (interactive) + (message "crdt.el version %s" crdt-version)) + (defgroup crdt nil "Collaborative editing using Conflict-free Replicated Data Types." :prefix "crdt-" @@ -40,6 +56,10 @@ "Default display name." :type 'string) +(defcustom crdt-default-session-name (format "%s_session" (user-login-name)) + "Default session name." + :type 'string) + (defcustom crdt-ask-for-password t "Ask for server password everytime a CRDT server is to be started." :type 'boolean) @@ -51,13 +71,11 @@ (defvar crdt--log-network-traffic nil "Debug switch to log network traffic to *Messages*.") -(require 'files) - -(defcustom crdt-tuntox-executable (executable-find "tuntox") +(defcustom crdt-tuntox-executable "tuntox" "Path to the tuntox binary." :type 'file) -(defcustom crdt-tuntox-key-path (expand-file-name "~") +(defcustom crdt-tuntox-key-path (if (featurep 'xdg) (xdg-data-home) "~/") "Path to save tuntox's private key." :type 'directory) @@ -65,14 +83,8 @@ "Start tuntox proxy for CRDT servers." :type '(choice boolean (const confirm))) -(require 'cl-lib) -(require 'subr-x) -(require 'url) - ;;; Pseudo cursor/region utils -(require 'color) - (defvar crdt-cursor-region-colors (let ((n 10)) (cl-loop for i below n @@ -111,8 +123,7 @@ "Move pseudo marked region overlay OV to mark between POS and MARK." (move-overlay ov (min pos mark) (max pos mark))) - -;; CRDT ID utils +;;; CRDT ID utils ;; CRDT IDs are represented by unibyte strings (for efficient comparison) ;; Every two bytes represent a big endian encoded integer ;; For base IDs, last two bytes are always representing site ID @@ -237,6 +248,7 @@ with ID and END-OF-BLOCK-P." The insert happens between BEG in BEG-OBJ and END in END-OBJ, if BEG-OBJ or END-OBJ is NIL, it is treated as current buffer. The search for start and end of CRDT ID block is limited by BEG-LIMIT and END-LIMIT." + (declare (indent 1) (debug ([&rest form] body))) `(let* ((not-begin (> ,beg ,(or beg-limit '(point-min)))) ; if it's nil, we're at the beginning of buffer (left-pos (1- ,beg)) (starting-id-pair (when not-begin (crdt--get-crdt-id-pair left-pos ,beg-obj))) @@ -265,6 +277,7 @@ Must be used inside CRDT--WITH-INSERTION-INFORMATION." (defmacro crdt--defvar-permanent-local (name &optional initial-value docstring) "Define a permanent local variable with NAME with INITIAL-VALUE and DOCSTRING." + (declare (indent 2) (doc-string 3) (debug defvar-local)) `(progn (defvar-local ,name ,initial-value ,docstring) (put ',name 'permanent-local t))) @@ -289,17 +302,18 @@ Must be used inside CRDT--WITH-INSERTION-INFORMATION." network-process network-clients next-client-id - buffer-table) + buffer-table ; maps buffer network name to buffer + follow-site-id) (defvar crdt--inhibit-update nil "When set, don't call CRDT--LOCAL-* on change. This is useful for functions that apply remote change to local buffer, to avoid recusive calling of CRDT synchronization functions.") (crdt--defvar-permanent-local crdt--changed-string nil - "Save changed substring in CRDT--BEFORE-CHANGE.") + "Save changed substring in CRDT--BEFORE-CHANGE.") (crdt--defvar-permanent-local crdt--changed-start nil - "Save start character address of changes in CRDT--BEFORE-CHANGE, + "Save start character address of changes in CRDT--BEFORE-CHANGE, to recover the portion being overwritten in CRDT--AFTER-CHANGE.") (crdt--defvar-permanent-local crdt--last-point nil) @@ -309,7 +323,8 @@ to recover the portion being overwritten in CRDT--AFTER-CHANGE.") (crdt--defvar-permanent-local crdt--last-process-mark-id nil) (crdt--defvar-permanent-local crdt--pseudo-cursor-table nil - "A hash table that maps SITE-ID to CONSes of the form (CURSOR-OVERLAY . REGION-OVERLAY).") + "A hash table that maps SITE-ID to CONSes. +Each element is of the form (CURSOR-OVERLAY . REGION-OVERLAY).") (cl-defstruct (crdt--contact-metadata (:constructor crdt--make-contact-metadata (display-name focused-buffer-name host service))) @@ -323,11 +338,7 @@ to recover the portion being overwritten in CRDT--AFTER-CHANGE.") lamport-timestamp species front-advance rear-advance plist) (crdt--defvar-permanent-local crdt--overlay-table nil - "A hash table that maps CONSes of the form (SITE-ID . LOGICAL-CLOCK) to overlays.") - -(defvar crdt--track-overlay-species nil) - -(crdt--defvar-permanent-local crdt--enabled-overlay-species nil) + "A hash table that maps CONSes of the form (SITE-ID . LOGICAL-CLOCK) to overlays.") (crdt--defvar-permanent-local crdt--buffer-network-name) @@ -335,29 +346,54 @@ to recover the portion being overwritten in CRDT--AFTER-CHANGE.") (crdt--defvar-permanent-local crdt--buffer-pseudo-process) +(defvar crdt--track-overlay-species nil + "Label any newly created overlay with its value as their ``species''. +You usually want to dynamically bound this variable, +so that overlays created during a dynamic extent +are categorized into the same ``species''. +You can then enable synchronizing those overlays using +function CRDT--ENABLE-OVERLAY-SPECIES.") + +(defvar-local crdt--enabled-overlay-species nil + "A list of ``species'' of overlays that are tracked and synchronized. +See CRDT--TRACK-OVERLAY-SPECIES. +You should always use CRDT--ENABLE-OVERLAY-SPECIES +and CRDT--DISABLE-OVERLAY-SPECIES to modify this variable +as those functions handle bookkeeping of +adding/removing actively tracked overlays.") + +(defvar-local crdt--enabled-text-properties nil + "A list of text properties that are tracked and synchronized.") + ;;; Global variables (defvar crdt--session-list nil) (defvar crdt--session-menu-buffer nil) +(defvar crdt--process nil + "Temporarily bound to the current network process when processing messages inside CRDT--NETWORK-FILTER.") + ;;; crdt-mode +(defvar crdt--hooks-alist + '((after-change-functions . crdt--after-change) + (before-change-functions . crdt--before-change) + (post-command-hook . crdt--post-command) + (deactivate-mark-hook . crdt--post-command) + (kill-buffer-hook . crdt--kill-buffer-hook) + (clone-buffer-hook . crdt--clone-buffer-hook) + (clone-indirect-buffer-hook . crdt--clone-buffer-hook))) + (defun crdt--install-hooks () "Install the hooks used by CRDT-MODE." - (add-hook 'after-change-functions #'crdt--after-change nil t) - (add-hook 'before-change-functions #'crdt--before-change nil t) - (add-hook 'post-command-hook #'crdt--post-command nil t) - (add-hook 'deactivate-mark-hook #'crdt--post-command nil t) - (add-hook 'kill-buffer-hook #'crdt--kill-buffer-hook nil t)) + (dolist (pair crdt--hooks-alist) + (add-hook (car pair) (cdr pair) nil t))) (defun crdt--uninstall-hooks () "Uninstall the hooks used by CRDT-MODE." - (remove-hook 'after-change-functions #'crdt--after-change t) - (remove-hook 'before-change-functions #'crdt--before-change t) - (remove-hook 'post-command-hook #'crdt--post-command t) - (remove-hook 'deactivate-mark-hook #'crdt--post-command t) - (remove-hook 'kill-buffer-hook #'crdt--kill-buffer-hook t)) + (dolist (pair crdt--hooks-alist) + (remove-hook (car pair) (cdr pair) t))) (defsubst crdt--clear-pseudo-cursor-table () "Remove all overlays in CRDT--PSEUDO-CURSOR-TABLE. @@ -369,20 +405,74 @@ Also set CRDT--PSEUDO-CURSOR-TABLE to NIL." crdt--pseudo-cursor-table) (setq crdt--pseudo-cursor-table nil))) -(define-minor-mode crdt-mode - "CRDT mode" nil " CRDT" nil - (if crdt-mode - (progn - (unless crdt--pseudo-cursor-table - (setq crdt--pseudo-cursor-table (make-hash-table))) - (unless crdt--overlay-table - (setq crdt--overlay-table (make-hash-table :test 'equal))) - (crdt--install-hooks)) - (crdt--uninstall-hooks) - (crdt--clear-pseudo-cursor-table) - (setq crdt--overlay-table nil))) +(defun crdt--after-change-major-mode () + "Re-enable CRDT-MODE after major mode change." + (when (and crdt--session crdt--buffer-network-name + (eq (current-buffer) + (gethash crdt--buffer-network-name + (crdt--session-buffer-table crdt--session)))) + (crdt--broadcast-maybe + (crdt--format-message `(ready ,crdt--buffer-network-name ,major-mode)) nil) + (crdt-mode))) -;;; Shared buffer utils +(add-hook 'after-change-major-mode-hook #'crdt--after-change-major-mode) + +(define-minor-mode crdt-mode + "Mode for source collaborative buffers." + :lighter " CRDT" + (if crdt-mode + (progn + (unless crdt--pseudo-cursor-table + (setq crdt--pseudo-cursor-table (make-hash-table))) + (unless crdt--overlay-table + (setq crdt--overlay-table (make-hash-table :test 'equal))) + (crdt--install-hooks)) + (crdt--uninstall-hooks) + (crdt--clear-pseudo-cursor-table) + (setq crdt--overlay-table nil))) + +(defun crdt--clone-buffer-hook () + (crdt-mode -1)) + +;;; Author visualization + +(defsubst crdt--visualize-author-1 (beg end site) + (remove-overlays beg end 'category 'crdt-visualize-author) + (cl-flet ((ov-alike-p (ov) + (and (eq (overlay-get ov 'category) 'crdt-visualize-author) + (eq (overlay-get ov 'crdt-site) site)))) + (or + (let ((ov-front (cl-find-if #'ov-alike-p (overlays-at (1- beg))))) + (when ov-front (move-overlay ov-front (overlay-start ov-front) end) t)) + (let ((ov-rear (cl-find-if #'ov-alike-p (overlays-at end)))) + (when ov-rear (move-overlay ov-rear beg (overlay-end ov-rear)) t)) + (let ((new-ov (make-overlay beg end nil t nil))) + (overlay-put new-ov 'category 'crdt-visualize-author) + (overlay-put new-ov 'crdt-site site) + (overlay-put new-ov 'face `(:underline ,(crdt--get-cursor-color site))))))) + +(defun crdt--visualize-author () + (save-restriction + (widen) + (let ((pos (point-max))) + (while (> pos (point-min)) + (let* ((prev-pos (previous-single-property-change pos 'crdt-id nil (point-min))) + (crdt-id (car-safe (crdt--get-crdt-id-pair prev-pos)))) + (when crdt-id (crdt--visualize-author-1 prev-pos pos (crdt--id-site crdt-id))) + (setq pos prev-pos)))))) + +(define-minor-mode crdt-visualize-author-mode + "Minor mode to visualize who wrote what." + :lighter " CRDT-VAuthor" + (if crdt-visualize-author-mode + (crdt--visualize-author) + (save-restriction + (widen) + (remove-overlays (point-min) (point-max) 'category 'crdt-visualize-author)))) + +;;; Error recovery + +(define-error 'crdt-sync-error "CRDT synchronization error") (defsubst crdt--server-p (&optional session) "Tell if SESSION is running as a server. @@ -392,20 +482,61 @@ If SESSION is nil, use current CRDT--SESSION." (or session crdt--session)) :server)) +(defmacro crdt--with-recover (&rest body) + "When any error in BODY occur, signal a CRDT-SYNC-ERROR instead. +This will hopefully trigger error recovery mechanism when further unwinding the stack." + (declare (indent 1) (debug (sexp def-body))) + `(condition-case nil + (progn ,@ body) + (error (signal 'crdt-sync-error nil)))) + +(defmacro crdt--with-should-not-error (name &rest body) + "When any error in BODY occur, print a report and stop CRDT in this buffer. +NAME is included in the report." + (declare (indent 1) (debug (sexp def-body))) + `(condition-case err + (progn ,@ body) + (error + (warn "CRDT mode exited in buffer %s because of error %s inside %s." + (current-buffer) err ',name) + (if (crdt--server-p) + (crdt-stop-share-buffer) + (remhash crdt--buffer-network-name (crdt--session-buffer-table crdt--session)) + (crdt--refresh-buffers-maybe) + (crdt-mode -1))))) + +(defun crdt--recover (&optional err) + "Try to recover from a synchronization failure. +Current buffer is assmuned to be the one with synchronization error. +If we are the server, ERR is the error we shall report to client." + (if (crdt--server-p) + (progn + (let ((message (crdt--format-message `(error ,crdt--buffer-network-name ,(car err) ,(crdt--readable-encode (cdr err)))))) + (process-send-string crdt--process message))) + (ding) + (read-only-mode) + (message "Synchronization error detected, try recovering...") + (crdt--broadcast-maybe + (crdt--format-message `(get ,crdt--buffer-network-name))))) + +;;; Shared buffer utils + (defmacro crdt--with-buffer-name (name &rest body) "Find CRDT shared buffer associated with NAME and evaluate BODY in it. +Any narrowing is temporarily disabled during evaluation of BODY. Also, try to recover from synchronization error if any error happens in BODY. Must be called when CURRENT-BUFFER is a CRDT status buffer. If such buffer doesn't exist yet, do nothing." + (declare (indent 1) (debug (sexp def-body))) `(let (crdt-buffer) (setq crdt-buffer (gethash ,name (crdt--session-buffer-table crdt--session))) (when (and crdt-buffer (buffer-live-p crdt-buffer)) (with-current-buffer crdt-buffer - (condition-case err - ,(cons 'progn body) - (error (if (crdt--server-p) - (signal (car err) (cdr err)) ; didn't implement server side recovery yet - (crdt--client-recover)))))))) + (save-restriction + (widen) + (condition-case err + ,(cons 'progn body) + (crdt-sync-error (crdt--recover err)))))))) (defmacro crdt--with-buffer-name-pull (name &rest body) "Find CRDT shared buffer associated with NAME and evaluate BODY in it. @@ -413,13 +544,14 @@ Must be called when CURRENT-BUFFER is a CRDT status buffer. If such buffer doesn't exist yet, request it from the server, and store the body in CRDT--BUFFER-SYNC-CALLBACK to evaluate it after synchronization is completed." + (declare (indent 1) (debug (sexp def-body))) `(let (crdt-buffer) (setq crdt-buffer (gethash ,name (crdt--session-buffer-table crdt--session))) (if (and crdt-buffer (buffer-live-p crdt-buffer)) (with-current-buffer crdt-buffer ,@body) (unless (process-contact (crdt--session-network-process crdt--session) :server) - (setq crdt-buffer (generate-new-buffer (format "crdt - %s" ,name))) + (setq crdt-buffer (generate-new-buffer (format "%s<%s>" ,name (crdt--session-name crdt--session)))) (puthash ,name crdt-buffer (crdt--session-buffer-table crdt--session)) (let ((session crdt--session)) (with-current-buffer crdt-buffer @@ -436,31 +568,72 @@ after synchronization is completed." ;;; Session menu -(defun crdt--session-menu-goto () - "Open the buffer menu for the session under point in CRDT session menu." - (interactive) - (let ((crdt--session (tabulated-list-get-id))) - (crdt-list-buffers))) +(defsubst crdt--get-session-names (server) + "Get session names for CRDT sessions (as in CRDT--SESSION-LIST). +If SERVER is non-NIL, return the list of names for server sessions. +Otherwise, return the list of names for client sessions." + (let (session-names) + (dolist (session crdt--session-list) + (when (eq (crdt--server-p session) server) + (push (crdt--session-name session) session-names))) + (nreverse session-names))) -(defun crdt--session-menu-kill () - "Kill the session under point in CRDT session menu." - (interactive) - (crdt--stop-session (tabulated-list-get-id))) +(defsubst crdt--get-session (name) + "Get the CRDT session object with NAME." + (cl-find name crdt--session-list + :test 'equal :key #'crdt--session-name)) + +(defun crdt--read-session (&optional filter) + "Prompt for a session name and return the corresponding session. +FILTER can be nil, 'server or 'client." + (crdt--get-session + (completing-read (format "Choose a%s session: " + (cl-ecase filter + ((server) " server") + ((client) " client") + ((nil) ""))) + (cl-ecase filter + ((server) (crdt--get-session-names t)) + ((client) (crdt--get-session-names nil)) + ((nil) (mapcar #'crdt--session-name crdt--session-list))) + nil t + (when (and crdt--session + (cl-ecase filter + ((server) (crdt--server-p)) + ((client) (not (crdt--server-p))) + ((nil) t))) + (crdt--session-name crdt--session))))) + +(defun crdt--read-session-maybe (&optional filter) + "Prompt for a session name and return the corresponding session. +Directly return the session name under point if in the session menu. +FILTER can be nil, 'server or 'client." + (if (eq major-mode 'crdt-session-menu-mode) + (or (tabulated-list-get-id) (signal 'quit nil)) + (if (and crdt--session + (cl-ecase filter + ((server) (crdt--server-p)) + ((client) (not (crdt--server-p))) + ((nil) t))) + crdt--session + (or (crdt--read-session filter) (signal 'quit nil))))) (defvar crdt-session-menu-mode-map (let ((map (make-sparse-keymap))) - (define-key map (kbd "RET") #'crdt--session-menu-goto) - (define-key map (kbd "k") #'crdt--session-menu-kill) + (define-key map (kbd "RET") #'crdt-list-buffers) + (define-key map [mouse-1] #'crdt-list-buffers) + (define-key map (kbd "k") #'crdt--stop-session) map)) (define-derived-mode crdt-session-menu-mode tabulated-list-mode - "CRDT User List" + "CRDT Session List" (setq tabulated-list-format [("Session Name" 15 t) ("Role" 7 t) ("My Name" 15 t) ("Buffers" 30 t) ("Users" 15 t)])) +;;;###autoload (defun crdt-list-sessions (&optional display-buffer) "Display a list of active CRDT sessions. If DISPLAY-BUFFER is provided, display the output there." @@ -505,54 +678,65 @@ If DISPLAY-BUFFER is provided, display the output there." ;;; Buffer menu -(defun crdt--buffer-menu-goto () - "Open the buffer under point in CRDT buffer menu." - (interactive) - (let ((name (tabulated-list-get-id))) - (crdt--with-buffer-name-pull name - (switch-to-buffer-other-window (current-buffer))))) +(defun crdt--read-buffer (session) + "Prompt for a buffer network name in SESSION." + (completing-read "Choose a buffer: " + (hash-table-keys (crdt--session-buffer-table session)) + nil t + (when (and (eq crdt--session session) + crdt--buffer-network-name) + crdt--buffer-network-name))) -(defun crdt--buffer-menu-kill () - "Stop sharing the buffer under point in CRDT buffer menu. -Only server can perform this action." - (interactive) - (if (crdt--server-p) - (let ((name (tabulated-list-get-id))) - (crdt--with-buffer-name name - (crdt-stop-share-buffer))) - (message "Only server can stop sharing a buffer."))) +(defun crdt--read-buffer-maybe (session) + "Prompt for a buffer network name in SESSION. +Directly return the buffer network name under point if in the buffer menu." + (or (and (eq crdt--session session) + (if (eq major-mode 'crdt-buffer-menu-mode) + (or (tabulated-list-get-id) (signal 'quit nil)) + crdt--buffer-network-name)) + (crdt--read-buffer session) + (signal 'quit nil))) + +(defun crdt-switch-to-buffer-other-window (session network-name) + "Open buffer with NETWORK-NAME in SESSION." + (interactive + (let ((session (crdt--read-session-maybe))) + (list session (crdt--read-buffer-maybe session)))) + (let ((crdt--session session)) + (crdt--with-buffer-name-pull network-name + (switch-to-buffer-other-window (current-buffer))))) (defvar crdt-buffer-menu-mode-map (let ((map (make-sparse-keymap))) - (define-key map (kbd "RET") #'crdt--buffer-menu-goto) - (define-key map (kbd "k") #'crdt--buffer-menu-kill) + (define-key map (kbd "RET") #'crdt-switch-to-buffer-other-window) + (define-key map [mouse-1] #'crdt-switch-to-buffer-other-window) + (define-key map (kbd "k") #'crdt-stop-share-buffer) map)) (define-derived-mode crdt-buffer-menu-mode tabulated-list-mode - "CRDT User List" + "CRDT Buffer List" (setq tabulated-list-format [("Local Buffer" 15 t) ("Network Name" 30 t) ("Users" 15 t)])) -(defun crdt-list-buffers (&optional crdt-buffer display-buffer) - "Display a list of buffers shared in the current CRDT session. -If DISPLAY-BUFFER is provided, display the output there. -Otherwise use a dedicated buffer for displaying active users on CRDT-BUFFER." - (interactive) - (with-current-buffer (or crdt-buffer (current-buffer)) - (unless crdt--session - (error "Not a CRDT shared buffer")) - (unless display-buffer +;;;###autoload +(defun crdt-list-buffers (&optional session) + "Display a list of buffers shared in SESSION." + (interactive (list (crdt--read-session-maybe))) + (let ((crdt--session (or session crdt--session))) + (with-current-buffer (current-buffer) + (unless crdt--session + (error "Not a CRDT shared buffer")) (unless (and (crdt--session-buffer-menu-buffer crdt--session) (buffer-live-p (crdt--session-buffer-menu-buffer crdt--session))) (setf (crdt--session-buffer-menu-buffer crdt--session) (generate-new-buffer (concat (crdt--session-name crdt--session) " buffers"))) (crdt--assimilate-session (crdt--session-buffer-menu-buffer crdt--session))) - (setq display-buffer (crdt--session-buffer-menu-buffer crdt--session))) - (crdt-refresh-buffers display-buffer) - (if (crdt--session-network-process crdt--session) - (switch-to-buffer display-buffer) - (switch-to-buffer-other-window display-buffer)))) + (let ((display-buffer (crdt--session-buffer-menu-buffer crdt--session))) + (crdt-refresh-buffers display-buffer) + (if (crdt--session-network-process crdt--session) + (switch-to-buffer display-buffer) + (switch-to-buffer-other-window display-buffer)))))) (defun crdt-refresh-buffers (display-buffer) "Refresh the CRDT buffer menu in DISPLAY-BUFFER." @@ -586,69 +770,95 @@ Otherwise use a dedicated buffer for displaying active users on CRDT-BUFFER." ;;; User menu -(defun crdt--user-menu-goto () - "Goto the cursor location of the user under point in CRDT user menu." - (interactive) - (let ((site-id (tabulated-list-get-id))) +(defun crdt--read-user (session) + "Prompt for a user name in SESSION." + ;; TODO: handle duplicated names + (let (site-id + (name + (completing-read "Choose a user: " + (mapcar #'crdt--contact-metadata-display-name + (hash-table-values (crdt--session-contact-table session))) + nil t))) + (maphash + (lambda (k v) + (when (string-equal (crdt--contact-metadata-display-name v) name) + (setq site-id k))) + (crdt--session-contact-table session)) + site-id)) + +(defun crdt--read-user-maybe (session) + "Prompt for a user name in SESSION. +Directly return the user name under point if in the user menu." + (or (and (eq crdt--session session) + (eq major-mode 'crdt-user-menu-mode) + (or (tabulated-list-get-id) (signal 'quit nil))) + (crdt--read-user session) + (signal 'quit nil))) + +(defun crdt-goto-user (session site-id) + "Goto the cursor location of user with SITE-ID in SESSION." + (interactive (let ((session (crdt--read-session-maybe))) + (list session (crdt--read-user-maybe session)))) + (let ((crdt--session session)) (if (eq site-id (crdt--session-local-id crdt--session)) - (switch-to-buffer-other-window + (funcall (if (eq major-mode 'crdt-user-menu-mode) + #'switch-to-buffer-other-window + #'switch-to-buffer) (gethash (crdt--session-focused-buffer-name crdt--session) (crdt--session-buffer-table crdt--session))) (unless (cl-block nil (let* ((metadata (or (gethash site-id (crdt--session-contact-table crdt--session)) (cl-return))) (buffer-name (or (crdt--contact-metadata-focused-buffer-name metadata) (cl-return)))) - (crdt--with-buffer-name-pull - buffer-name - (switch-to-buffer-other-window (current-buffer)) - (ignore-errors (goto-char (overlay-start (car (gethash site-id crdt--pseudo-cursor-table))))) - t))) + (crdt--with-buffer-name-pull buffer-name + (switch-to-buffer-other-window (current-buffer)) + (ignore-errors (goto-char (overlay-start (car (gethash site-id crdt--pseudo-cursor-table))))) + t))) (message "Doesn't have position information for this user yet."))))) -(defun crdt--user-menu-kill () - "Disconnect the user under point in CRDT user menu. +(defun crdt-kill-user (session site-id) + "Disconnect the user with SITE-ID in SESSION. Only server can perform this action." - (interactive) - (if (crdt--server-p) - (let ((site-id (tabulated-list-get-id))) - (if site-id - (if (eq site-id (crdt--session-local-id crdt--session)) - (message "Suicide is not allowed.") - (dolist (p (process-list)) - (when (eq (process-get p 'client-id) site-id) - (delete-process p)))) - (message "We somehow don't have the SITE-ID for this user. - Please submit a bug report to crdt.el maintainer."))) - (message "Only server can disconnect a user."))) + (interactive (let ((session (crdt--read-session-maybe 'server))) + (list session (crdt--read-user-maybe session)))) + (let ((crdt--session session)) + (if (crdt--server-p) + (if (eq site-id (crdt--session-local-id crdt--session)) + (error "Suicide is not allowed") + (dolist (p (process-list)) + (when (eq (process-get p 'client-id) site-id) + (delete-process p)))) + (message "Only server can disconnect a user.")))) (defvar crdt-user-menu-mode-map (let ((map (make-sparse-keymap))) - (define-key map (kbd "RET") #'crdt--user-menu-goto) - (define-key map (kbd "k") #'crdt--user-menu-kill) + (define-key map (kbd "RET") #'crdt-goto-user) + (define-key map [mouse-1] #'crdt-goto-user) + (define-key map (kbd "k") #'crdt-kill-user) + (define-key map (kbd "f") #'crdt-follow-user) map)) (define-derived-mode crdt-user-menu-mode tabulated-list-mode "CRDT User List" (setq tabulated-list-format [("Display Name" 15 t) + ("Follow" 7 t) ("Focused Buffer" 30 t) ("Address" 15 t)])) -(defun crdt-list-users (&optional crdt-buffer display-buffer) - "Display a list of active users working on a CRDT-shared session. -Find the session in CRDT-BUFFER if non NIL, or current buffer. -If DISPLAY-BUFFER is provided, display the output there. -Otherwise create a dedicated buffer." - (interactive) - (with-current-buffer (or crdt-buffer (current-buffer)) - (unless crdt--session - (error "Not a CRDT shared buffer")) - (unless display-buffer +;;;###autoload +(defun crdt-list-users (&optional session) + "Display a list of active users working on a SESSION." + (interactive (list (crdt--read-session-maybe))) + (let ((crdt--session session)) + (with-current-buffer (current-buffer) + (unless crdt--session + (error "Not a CRDT shared buffer")) (unless (and (crdt--session-user-menu-buffer crdt--session) (buffer-live-p (crdt--session-user-menu-buffer crdt--session))) (setf (crdt--session-user-menu-buffer crdt--session) (generate-new-buffer (concat (crdt--session-name crdt--session) " users"))) (crdt--assimilate-session (crdt--session-user-menu-buffer crdt--session))) - (setq display-buffer (crdt--session-user-menu-buffer crdt--session))) - (crdt-refresh-users display-buffer) - (switch-to-buffer-other-window display-buffer))) + (let ((display-buffer (crdt--session-user-menu-buffer crdt--session))) + (crdt-refresh-users display-buffer) + (switch-to-buffer-other-window display-buffer))))) (defun crdt-refresh-users (display-buffer) "Refresh the CRDT user menu in DISPLAY-BUFFER." @@ -656,7 +866,7 @@ Otherwise create a dedicated buffer." (crdt-user-menu-mode) (setq tabulated-list-entries nil) (push (list (crdt--session-local-id crdt--session) - (vector (crdt--session-local-name crdt--session) + (vector (crdt--session-local-name crdt--session) "" (or (crdt--session-focused-buffer-name crdt--session) "--") "*myself*")) tabulated-list-entries) @@ -672,7 +882,9 @@ Otherwise create a dedicated buffer." (put-text-property (1- (length colored-name)) (length colored-name) 'face `(:background ,(crdt--get-cursor-color k)) colored-name) - (vector colored-name focused-buffer-name (format "%s:%s" host service))))) + (vector colored-name (if (eq k (crdt--session-follow-site-id crdt--session)) + "yes" "") + focused-buffer-name (format "%s:%s" host service))))) tabulated-list-entries)) (crdt--session-contact-table crdt--session)) (tabulated-list-init-header) @@ -684,6 +896,27 @@ Otherwise create a dedicated buffer." (crdt-refresh-users (crdt--session-user-menu-buffer crdt--session))) (crdt--refresh-buffers-maybe)) +(defun crdt-follow-user (session site-id) + "Toggle following user with SITE-ID in SESSION." + (interactive (let ((session (crdt--read-session-maybe))) + (list session (crdt--read-user-maybe session)))) + (let ((crdt--session session)) + (if (eq site-id (crdt--session-local-id crdt--session)) + (error "Narcissism is not allowed") + (if (eq site-id (crdt--session-follow-site-id crdt--session)) + (crdt-stop-follow) + (setf (crdt--session-follow-site-id crdt--session) site-id)) + (crdt--refresh-users-maybe)))) + +(defun crdt-stop-follow () + "Stop following user if any." + (interactive) + (message "Stop following %s." + (crdt--contact-metadata-display-name + (gethash (crdt--session-follow-site-id crdt--session) + (crdt--session-contact-table crdt--session)))) + (setf (crdt--session-follow-site-id crdt--session) nil)) + (defun crdt--kill-buffer-hook () "Kill buffer hook for CRDT shared buffers. It informs other peers that the buffer is killed." @@ -696,61 +929,87 @@ It informs other peers that the buffer is killed." (crdt--broadcast-maybe (crdt--format-message `(focus ,(crdt--session-local-id crdt--session) nil))) (setf (crdt--session-focused-buffer-name crdt--session) nil)) + (when (crdt--server-p) + (crdt-stop-share-buffer)) (crdt--refresh-users-maybe))) ;;; CRDT insert/delete -(defsubst crdt--base64-encode-maybe (str) - "Base64 encode STR if it's a string, or return NIL if STR is NIL." - (when str (base64-encode-string str))) +(defsubst crdt--text-property-assimilate + (template template-beg template-end beg prop &optional object) + "Make PROP after BEG in OBJECT the same as part of TEMPLATE. +The part between TEMPLATE-BEG and TEMPLATE-END is used. +If OBJECT is NIL, use current buffer." + (let (next-pos + (pos template-beg) + (limit template-end) + (offset (- beg template-beg))) + (while (< pos limit) + (setq next-pos (next-single-property-change pos prop template limit)) + (put-text-property (+ offset pos) (+ offset next-pos) prop + (get-text-property pos prop template) + object) + (setq pos next-pos)))) + +(defsubst crdt--buffer-substring (beg end) + "Return the contents between BEG and END of the current buffer as a string. +Copies text properties in CRDT--ENABLED-TEXT-PROPERTIES." + (let ((string (buffer-substring-no-properties beg end))) + (dolist (prop crdt--enabled-text-properties) + (crdt--text-property-assimilate nil beg end 0 prop string)) + string)) (defun crdt--local-insert (beg end) "To be called after a local insert happened in current buffer from BEG to END. Returns a list of (insert type) messages to be sent." + (when crdt-visualize-author-mode + (crdt--visualize-author-1 beg end (crdt--session-local-id crdt--session))) (let (resulting-commands) - (crdt--with-insertion-information - (beg end) - (unless (crdt--split-maybe) - (when (and not-begin - (eq (crdt--id-site starting-id) (crdt--session-local-id crdt--session)) - (crdt--end-of-block-p left-pos)) - ;; merge crdt id block - (let* ((max-offset crdt--max-value) - (merge-end (min end (+ (- max-offset left-offset 1) beg)))) - (unless (= merge-end beg) - (put-text-property beg merge-end 'crdt-id starting-id-pair) - (let ((virtual-id (substring starting-id))) - (crdt--set-id-offset virtual-id (1+ left-offset)) - (push `(insert ,crdt--buffer-network-name - ,(base64-encode-string virtual-id) ,beg - ,(buffer-substring-no-properties beg merge-end)) - resulting-commands)) - (cl-incf left-offset (- merge-end beg)) - (setq beg merge-end))))) - (while (< beg end) - (let ((block-end (min end (+ crdt--max-value beg)))) - (let* ((ending-id (if not-end (crdt--get-starting-id end) "")) - (new-id (crdt--generate-id starting-id left-offset - ending-id (if not-end (crdt--id-offset ending-id) 0) - (crdt--session-local-id crdt--session)))) - (put-text-property beg block-end 'crdt-id (cons new-id t)) - (push `(insert ,crdt--buffer-network-name - ,(base64-encode-string new-id) ,beg - ,(buffer-substring-no-properties beg block-end)) - resulting-commands) - (setq beg block-end) - (setq left-offset (1- crdt--max-value)) ; this is always true when we need to continue - (setq starting-id new-id))))) + (crdt--with-insertion-information (beg end) + (unless (crdt--split-maybe) + (when (and not-begin + (eq (crdt--id-site starting-id) (crdt--session-local-id crdt--session)) + (crdt--end-of-block-p left-pos)) + ;; merge crdt id block + (let* ((max-offset crdt--max-value) + (merge-end (min end (+ (- max-offset left-offset 1) beg)))) + (unless (= merge-end beg) + (put-text-property beg merge-end 'crdt-id starting-id-pair) + (let ((virtual-id (substring starting-id))) + (crdt--set-id-offset virtual-id (1+ left-offset)) + (push `(insert ,crdt--buffer-network-name + ,virtual-id ,beg + ,(crdt--buffer-substring beg merge-end)) + resulting-commands)) + (cl-incf left-offset (- merge-end beg)) + (setq beg merge-end))))) + (while (< beg end) + (let ((block-end (min end (+ crdt--max-value beg)))) + (let* ((ending-id (if not-end (crdt--get-starting-id end) "")) + (new-id (crdt--generate-id starting-id left-offset + ending-id (if not-end (crdt--id-offset ending-id) 0) + (crdt--session-local-id crdt--session)))) + (put-text-property beg block-end 'crdt-id (cons new-id t)) + (push `(insert ,crdt--buffer-network-name + ,new-id ,beg + ,(crdt--buffer-substring beg block-end)) + resulting-commands) + (setq beg block-end) + (setq left-offset (1- crdt--max-value)) ; this is always true when we need to continue + (setq starting-id new-id))))) ;; (crdt--verify-buffer) (nreverse resulting-commands))) (defun crdt--find-id (id pos &optional before) "Find the first position *after* ID if BEFORE is NIL or *before* ID otherwise. -Start the search from POS." +Start the search from POS. +This function doesn't handle empty string convention in the crdt.el protocol. +To convert an ID in protocol message to a position in the buffer, +CRDT--ID-TO-POS is usually more appropriate." (let* ((left-pos (previous-single-property-change (min (1+ pos) (point-max)) 'crdt-id nil (point-min))) (left-id (crdt--get-starting-id left-pos)) - (right-pos (next-single-property-change pos 'crdt-id nil (point-max))) + (right-pos (next-single-property-change (min pos (point-max)) 'crdt-id nil (point-max))) (right-id (crdt--get-starting-id right-pos)) (moving-forward nil)) (cl-macrolet ((move-forward () @@ -800,17 +1059,20 @@ Start the search around POSITION-HINT." (goto-char beg) (insert content) (setq end (point)) + (when crdt-visualize-author-mode + (crdt--visualize-author-1 beg end (crdt--id-site id))) ;; work around for input method overlays (cl-loop for ov in (overlays-at beg) - do (unless (overlay-get ov 'crdt-meta) + do (unless (or (overlay-get ov 'crdt-meta) + (memq (overlay-get ov 'category) + '(crdt-visualize-author crdt-pseudo-cursor))) (when (eq (overlay-start ov) beg) (move-overlay ov end (overlay-end ov))))) (with-silent-modifications (let ((real-end end)) (unless (get-text-property end 'crdt-id) (setq end (next-single-property-change end 'crdt-id nil (point-max)))) - (crdt--with-insertion-information - (beg end) + (crdt--with-insertion-information (beg end) (let ((base-length (- (string-bytes starting-id) 2))) (if (and (eq (string-bytes id) (string-bytes starting-id)) (eq t (compare-strings starting-id 0 base-length @@ -822,22 +1084,25 @@ Start the search around POSITION-HINT." ;; (crdt--verify-buffer) ) +(defsubst crdt--changed-string (beg length) + "Retrieve part of CRDT--CHANGED-STRING starting at BEG with LENGTH before change." + (let ((from (- beg crdt--changed-start))) + (substring crdt--changed-string from (+ from length)))) + (defun crdt--local-delete (beg end length) "Handle local deletion event and return a message to be sent to other peers. The deletion happens between BEG and END, and have LENGTH." (let ((outer-end end) (crdt--changed-string (crdt--changed-string beg length))) - (crdt--with-insertion-information - (beg 0 nil crdt--changed-string nil (length crdt--changed-string)) - (when (crdt--split-maybe) - (let* ((not-end (< outer-end (point-max))) - (ending-id (when not-end (crdt--get-starting-id outer-end)))) - (when (and not-end (eq starting-id (crdt--get-starting-id outer-end))) - (crdt--set-id outer-end - (crdt--id-replace-offset ending-id (+ 1 left-offset (length crdt--changed-string)))))))) - (crdt--with-insertion-information - ((length crdt--changed-string) outer-end crdt--changed-string nil 0 nil) - (crdt--split-maybe)) + (crdt--with-insertion-information (beg 0 nil crdt--changed-string nil (length crdt--changed-string)) + (when (crdt--split-maybe) + (let* ((not-end (< outer-end (point-max))) + (ending-id (when not-end (crdt--get-starting-id outer-end)))) + (when (and not-end (eq starting-id (crdt--get-starting-id outer-end))) + (crdt--set-id outer-end + (crdt--id-replace-offset ending-id (+ 1 left-offset (length crdt--changed-string)))))))) + (crdt--with-insertion-information ((length crdt--changed-string) outer-end crdt--changed-string nil 0 nil) + (crdt--split-maybe)) ;; (crdt--verify-buffer) `(delete ,crdt--buffer-network-name ,beg ,@ (crdt--dump-ids 0 (length crdt--changed-string) crdt--changed-string t)))) @@ -873,67 +1138,60 @@ Start the search for those ID-ITEMs around POSITION-HINT." "Before change hook used by CRDT-MODE. It saves the content to be changed (between BEG and END) into CRDT--CHANGED-STRING." (unless crdt--inhibit-update - (setq crdt--changed-string (buffer-substring beg end)) + (setq crdt--changed-string (crdt--buffer-substring beg end)) + (crdt--text-property-assimilate nil beg end 0 + 'crdt-id crdt--changed-string) (setq crdt--changed-start beg))) -(defsubst crdt--changed-string (beg length) - "Retrieve part of CRDT--CHANGED-STRING starting at BEG with LENGTH before change." - (let ((from (- beg crdt--changed-start))) - (substring crdt--changed-string from (+ from length)))) - (defsubst crdt--crdt-id-assimilate (template beg &optional object) "Make the CRDT-ID property after BEG in OBJECT the same as TEMPLATE. TEMPLATE should be a string. If OBJECT is NIL, use current buffer." - (let (next-pos - (pos 0) - (limit (length template))) - (while (< pos limit) - (setq next-pos (next-single-property-change pos 'crdt-id template limit)) - (put-text-property (+ beg pos) (+ beg next-pos) 'crdt-id - (get-text-property pos 'crdt-id template) - object) - (setq pos next-pos)))) + (crdt--text-property-assimilate template 0 (length template) beg 'crdt-id object)) (defun crdt--after-change (beg end length) "After change hook used by CRDT-MODE. It examine (CRDT--CHANGED-STRING) (should be saved by CRDT--BEFORE-STRING) and current content between BEG and END with LENGTH, update the CRDT-ID for any newly inserted text, and send message to other peers if needed." - (when (markerp beg) - (setq beg (marker-position beg))) - (when (markerp end) - (setq end (marker-position end))) - (mapc (lambda (ov) - (when (eq (overlay-get ov 'category) 'crdt-pseudo-cursor) - (crdt--move-cursor ov beg))) - (overlays-in beg (min (point-max) (1+ beg)))) - (when (crdt--session-local-id crdt--session) ; LOCAL-ID is NIL when a client haven't received the first sync message - (unless crdt--inhibit-update - (let ((crdt--inhibit-update t)) - ;; we're only interested in text change - ;; ignore property only changes - (save-excursion - (goto-char beg) - (if (and (= length (- end beg)) - (string-equal (crdt--changed-string beg length) - (buffer-substring-no-properties beg end))) - (crdt--crdt-id-assimilate (crdt--changed-string beg length) beg) - (widen) - (with-silent-modifications - (unless (= length 0) - (crdt--broadcast-maybe - (crdt--format-message (crdt--local-delete beg end length)))) - (unless (= beg end) - (dolist (message (crdt--local-insert beg end)) - (crdt--broadcast-maybe - (crdt--format-message message))))))) - ;; process-mark synchronization is dependent on correct CRDT-ID - ;; therefore we must do it after the insert/change stuff is done - (crdt--send-process-mark-maybe) - ;; see if region stuff changed - (let ((cursor-message (crdt--local-cursor))) - (when cursor-message - (crdt--broadcast-maybe (crdt--format-message cursor-message)))))))) + (crdt--with-should-not-error 'crdt--after-change + (when (markerp beg) + (setq beg (marker-position beg))) + (when (markerp end) + (setq end (marker-position end))) + (mapc (lambda (ov) + (when (eq (overlay-get ov 'category) 'crdt-pseudo-cursor) + (crdt--move-cursor ov beg))) + (overlays-in beg (min (point-max) (1+ beg)))) + (when (crdt--session-local-id crdt--session) ; LOCAL-ID is NIL when a client haven't received the first sync message + (unless crdt--inhibit-update + (let ((crdt--inhibit-update t)) + ;; we're only interested in text change + ;; ignore property only changes + ;; todo: track properties in crdt--enabled-text-properties + (save-excursion + (save-restriction + (goto-char beg) + (if (and (= length (- end beg)) + (equal-including-properties (crdt--changed-string beg length) + (crdt--buffer-substring beg end))) + (crdt--crdt-id-assimilate (crdt--changed-string beg length) beg) + (widen) + (with-silent-modifications + (unless (= length 0) + (crdt--broadcast-maybe + (crdt--format-message (crdt--local-delete beg end length)))) + (unless (= beg end) + (dolist (message (crdt--local-insert beg end)) + (crdt--broadcast-maybe + (crdt--format-message message)))))))) + ;; see if region stuff changed + (let ((cursor-message (crdt--local-cursor))) + (when cursor-message + (crdt--broadcast-maybe (crdt--format-message cursor-message)))) + ;; process-mark synchronization is dependent on correct CRDT-ID + ;; therefore we must do it after the insert/change stuff is done + (crdt--send-process-mark-maybe) + (crdt--send-variables-maybe)))))) ;;; CRDT point/mark synchronization @@ -952,7 +1210,7 @@ If POINT-CRDT-ID is NIL, remove the pseudo cursor and region overlays for this site. The mark for that site is at MARK-CRDT-ID, whose search starts around MARK-POSITION-HINT. -If MARK-CRDT-ID, deactivate the pseudo region overlay." +If MARK-CRDT-ID is NIL, deactivate the pseudo region overlay." (when (and site-id (not (eq site-id (crdt--session-local-id crdt--session)))) (let ((ov-pair (gethash site-id crdt--pseudo-cursor-table))) (if point-crdt-id @@ -969,7 +1227,12 @@ If MARK-CRDT-ID, deactivate the pseudo region overlay." (setq ov-pair (puthash site-id (cons new-cursor new-region) crdt--pseudo-cursor-table)))) (crdt--move-cursor (car ov-pair) point) - (crdt--move-region (cdr ov-pair) point mark)) + (crdt--move-region (cdr ov-pair) point mark) + (when (eq site-id (crdt--session-follow-site-id crdt--session)) + (goto-char point) + (let ((cursor-message (crdt--local-cursor))) + (when cursor-message + (crdt--broadcast-maybe (crdt--format-message cursor-message)))))) (when ov-pair (remhash site-id crdt--pseudo-cursor-table) (delete-overlay (car ov-pair)) @@ -992,31 +1255,35 @@ Always return a message otherwise." (overlays-in (point-max) (point-max)))) (setq crdt--last-point point) (setq crdt--last-mark mark) - (let ((point-id-base64 (base64-encode-string (crdt--get-id point))) - (mark-id-base64 (when mark (base64-encode-string (crdt--get-id mark))))) + (save-restriction + (widen) `(cursor ,crdt--buffer-network-name ,(crdt--session-local-id crdt--session) - ,point ,point-id-base64 ,mark ,mark-id-base64))))) + ,point ,(crdt--get-id point) ,mark ,(when mark (crdt--get-id mark))))))) (defun crdt--post-command () "Post command hook used by CRDT-MODE. Check if focused buffer and cursor/mark position are changed. Send message to other peers about any changes." - (unless (eq crdt--buffer-network-name (crdt--session-focused-buffer-name crdt--session)) - (crdt--broadcast-maybe - (crdt--format-message `(focus ,(crdt--session-local-id crdt--session) ,crdt--buffer-network-name))) - (setf (crdt--session-focused-buffer-name crdt--session) crdt--buffer-network-name) - (crdt--refresh-users-maybe)) - (let ((cursor-message (crdt--local-cursor))) - (when cursor-message - (crdt--broadcast-maybe (crdt--format-message cursor-message))))) - + (crdt--with-should-not-error crdt--post-command + (unless (eq crdt--buffer-network-name (crdt--session-focused-buffer-name crdt--session)) + (crdt--broadcast-maybe + (crdt--format-message `(focus ,(crdt--session-local-id crdt--session) ,crdt--buffer-network-name))) + (setf (crdt--session-focused-buffer-name crdt--session) crdt--buffer-network-name) + (crdt--refresh-users-maybe)) + (let ((cursor-message (crdt--local-cursor))) + (when cursor-message + (crdt--broadcast-maybe (crdt--format-message cursor-message)))) + ;; process-mark synchronization is dependent on correct CRDT-ID + ;; therefore we must do it after the insert/change stuff is done + (crdt--send-process-mark-maybe) + (crdt--send-variables-maybe))) ;;; CRDT ID (de)serialization (defun crdt--dump-ids (beg end object &optional omit-end-of-block-p include-content) "Serialize all CRDT IDs in OBJECT from BEG to END into a list. -The list contains CONSes of the form (LENGTH CRDT-ID-BASE64 END-OF-BLOCK-P), -or (LENGTH CRDT-ID-BASE64) if OMIT-END-OF-BLOCK-P is non-NIL, +The list contains CONSes of the form (LENGTH CRDT-ID END-OF-BLOCK-P), +or (LENGTH CRDT-ID) if OMIT-END-OF-BLOCK-P is non-NIL, in the order that they appears in the document. If INCLUDE-CONTENT is non-NIL, the list contains STRING instead of LENGTH." (let (ids (pos end)) @@ -1024,15 +1291,14 @@ If INCLUDE-CONTENT is non-NIL, the list contains STRING instead of LENGTH." (let ((prev-pos (previous-single-property-change pos 'crdt-id object beg))) (when (crdt--get-crdt-id-pair prev-pos object) (push (cons (if include-content - (cond ((not object) (buffer-substring-no-properties prev-pos pos)) + (cond ((not object) (crdt--buffer-substring prev-pos pos)) ((bufferp object) (with-current-buffer object - (buffer-substring-no-properties prev-pos pos))) + (crdt--buffer-substring prev-pos pos))) (t (substring object prev-pos pos))) (- pos prev-pos)) (cl-destructuring-bind (id . eob) (crdt--get-crdt-id-pair prev-pos object) - (let ((id-base64 (base64-encode-string id))) - (if omit-end-of-block-p (list id-base64) (list id-base64 eob))))) + (if omit-end-of-block-p (list id) (list id eob)))) ids)) (setq pos prev-pos))) ids)) @@ -1042,9 +1308,8 @@ If INCLUDE-CONTENT is non-NIL, the list contains STRING instead of LENGTH." into current buffer." (goto-char (point-min)) (dolist (id-item ids) - (cl-destructuring-bind (content id-base64 eob) id-item - (insert (propertize content 'crdt-id - (cons (base64-decode-string id-base64) eob)))))) + (cl-destructuring-bind (content id eob) id-item + (insert (propertize content 'crdt-id (cons id eob)))))) (defun crdt--verify-buffer () "Debug helper function. @@ -1064,17 +1329,6 @@ Verify that CRDT IDs in a document follows ascending order." (setq pos next-pos) (setq id next-id)))))) -;;; Recovery - -(defun crdt--client-recover () - "Try to recover from a synchronization failure from a client. -Current buffer is assmuned to be the one with synchronization error." - (ding) - (read-only-mode) - (message "Synchronization error detected, try recovering...") - (crdt--broadcast-maybe - (crdt--format-message `(get ,crdt--buffer-network-name)))) - ;;; Network protocol (defun crdt--format-message (args) @@ -1084,6 +1338,38 @@ Return the string." (print-length nil)) (prin1-to-string args))) +(cl-defun crdt--readable-encode (object &optional (no-properties t)) + "Return an object ``similar'' to OBJECT at best effort. +If NO-PROPERTIES is non-nil, +omit text properties of any strings in the returned object. +The returned object has a printed representation that can be read back. +The symbol CRDT-EVAL is used as an special marker in the encoding +and the behavior is undefined if OBJECT itself contains this symbol." + (cl-typecase object + (string (if no-properties (substring-no-properties object) object)) + ((or symbol number character) object) + (vector (cl-map 'vector #'crdt--readable-encode object)) + (cons (cons (crdt--readable-encode (car object)) (crdt--readable-encode (cdr object)))) + (buffer (list 'crdt-eval 'buffer + (buffer-local-value 'crdt--buffer-network-name object))) + (t (list 'crdt-eval 'unreadable + (prin1-to-string object))))) + +(defun crdt--readable-decode (object) + "Reconstruct the original object from CRDT--READABLE-ENCODEd OBJECT at best effort." + (cl-typecase object + (cons (if (eq (car object) 'crdt-eval) + (cl-case (cadr object) + ((buffer) (crdt--with-buffer-name (caddr object) (current-buffer))) + ((unreadable) (caddr object))) + (cons (crdt--readable-decode (car object)) (crdt--readable-decode (cdr object))))) + (vector (cl-map 'vector #'crdt--readable-decode object)) + (t object))) + +(defsubst crdt--log-send-network-traffic (message-string) + (when crdt--log-network-traffic + (message "Send %s" message-string))) + (cl-defun crdt--broadcast-maybe (message-string &optional (without t)) "Broadcast or send MESSAGE-STRING. If (CRDT--SESSION-NETWORK-PROCESS CRDT--SESSION) is a server process, @@ -1091,21 +1377,56 @@ broadcast MESSAGE-STRING to clients except the one of which CLIENT-ID property is EQ to WITHOUT. If (CRDT--SESSION-NETWORK-PROCESS CRDT--SESSION) is a client process, send MESSAGE-STRING to server when WITHOUT is non-nil." - (when crdt--log-network-traffic - (message "Send %s" message-string)) (if (process-contact (crdt--session-network-process crdt--session) :server) (dolist (client (crdt--session-network-clients crdt--session)) (when (and (eq (process-status client) 'open) (not (eq (process-get client 'client-id) without))) + (crdt--log-send-network-traffic message-string) (process-send-string client message-string) ;; (run-at-time 1 nil #'process-send-string client message-string) ;; ^ quick dirty way to simulate network latency, for debugging )) (when without + (crdt--log-send-network-traffic message-string) (process-send-string (crdt--session-network-process crdt--session) message-string) ;; (run-at-time 1 nil #'process-send-string (crdt--session-network-process crdt--session) message-string) ))) +(defvar crdt--message-handler-table (make-hash-table) + "Map CRDT message type to handler function.") + +(cl-defmacro define-crdt-message-handler (type arglist &body body) + "Define a crdt message handler. +Define a function CRDT--HANDLE-MESSAGE-[TYPE] with ARGLIST and BODY and +use it to handle message TYPE." + (declare (debug + (&define name cl-lambda-list cl-declarations-or-string def-body)) + (doc-string 3) + (indent 2)) + (let ((function-name (intern (concat "crdt--handle-message-" (symbol-name type))))) + `(progn + (cl-defun ,function-name ,arglist ,@body) + (puthash ',type ',function-name crdt--message-handler-table)))) + +(defvar crdt--message-string nil + "Bound to the string representation of the message inside message handler. +So that we don't need to convert MESSAGE to string again +when we need to broadcast it.") + +(define-error 'crdt-unrecognized-message "Unhandled crdt-unrecognized-message.") + +(defsubst crdt-process-message (message string) + (let ((crdt--message-string string)) + (let ((handler (gethash (car message) crdt--message-handler-table))) + (if handler + (apply handler (cdr message)) + (message "Unrecognized message %S from %s:%s." + message (process-contact crdt--process :host) (process-contact crdt--process :service)) + (signal 'crdt-unrecognized-message nil))))) + +(defsubst crdt-process-message-1 (message) + (crdt-process-message message (crdt--format-message message))) + (defsubst crdt--overlay-add-message (id clock species front-advance rear-advance beg end) "Create an overlay-add message to be sent to peers. The overlay is generated at site with ID and logical CLOCK. @@ -1114,199 +1435,196 @@ The overlay is FRONT-ADVANCE and REAR-ADVANCE, and lies between BEG and END." `(overlay-add ,crdt--buffer-network-name ,id ,clock ,species ,front-advance ,rear-advance ,beg ,(if front-advance - (base64-encode-string (crdt--get-id beg)) - (crdt--base64-encode-maybe (crdt--get-id (1- beg)))) + (crdt--get-id beg) + (crdt--get-id (1- beg))) ,end ,(if rear-advance - (base64-encode-string (crdt--get-id end)) - (crdt--base64-encode-maybe (crdt--get-id (1- end)))))) + (crdt--get-id end) + (crdt--get-id (1- end))))) (defsubst crdt--generate-challenge () "Generate a challenge string for authentication." (apply #'unibyte-string (cl-loop for i below 32 collect (random 256)))) -(defsubst crdt--sync-buffer-to-client (buffer process) +(defsubst crdt--sync-buffer-to-client (buffer) "Send messages to a client about the full state of BUFFER. -The network process for the client connection is PROCESS." +CRDT--PROCESS should be bound to The network process for the client connection." (with-current-buffer buffer - (process-send-string process - (crdt--format-message - `(sync - ,crdt--buffer-network-name - ,@ (crdt--dump-ids (point-min) (point-max) nil nil t)))) - ;; synchronize cursor - (maphash (lambda (site-id ov-pair) - (cl-destructuring-bind (cursor-ov . region-ov) ov-pair - (let* ((point (overlay-start cursor-ov)) - (region-beg (overlay-start region-ov)) - (region-end (overlay-end region-ov)) - (mark (if (eq point region-beg) - (unless (eq point region-end) region-end) - region-beg)) - (point-id-base64 (base64-encode-string (crdt--get-id point))) - (mark-id-base64 (when mark (base64-encode-string (crdt--get-id mark))))) - (process-send-string process - (crdt--format-message - `(cursor ,crdt--buffer-network-name ,site-id - ,point ,point-id-base64 ,mark ,mark-id-base64)))))) - crdt--pseudo-cursor-table) - (process-send-string process (crdt--format-message (crdt--local-cursor nil))) + (save-restriction + (widen) + (process-send-string crdt--process + (crdt--format-message + `(sync + ,crdt--buffer-network-name + ,@ (crdt--dump-ids (point-min) (point-max) nil nil t)))) + (process-send-string crdt--process (crdt--format-message `(ready ,crdt--buffer-network-name ,major-mode))) - ;; synchronize tracked overlay - (maphash (lambda (k ov) - (let ((meta (overlay-get ov 'crdt-meta))) - (process-send-string - process - (crdt--format-message (crdt--overlay-add-message - (car k) (cdr k) - (crdt--overlay-metadata-species meta) - (crdt--overlay-metadata-front-advance meta) - (crdt--overlay-metadata-rear-advance meta) - (overlay-start ov) - (overlay-end ov)))) - (cl-loop for (prop value) on (crdt--overlay-metadata-plist meta) by #'cddr - do (process-send-string - process - (crdt--format-message `(overlay-put ,crdt--buffer-network-name - ,(car k) ,(cdr k) ,prop ,value)))))) - crdt--overlay-table) + ;; synchronize cursor + (maphash (lambda (site-id ov-pair) + (cl-destructuring-bind (cursor-ov . region-ov) ov-pair + (let* ((point (overlay-start cursor-ov)) + (region-beg (overlay-start region-ov)) + (region-end (overlay-end region-ov)) + (mark (if (eq point region-beg) + (unless (eq point region-end) region-end) + region-beg))) + (process-send-string crdt--process + (crdt--format-message + `(cursor ,crdt--buffer-network-name ,site-id + ,point ,(crdt--get-id point) + ,mark ,(when mark (crdt--get-id mark)))))))) + crdt--pseudo-cursor-table) + (process-send-string crdt--process (crdt--format-message (crdt--local-cursor nil))) - ;; synchronize process marker if there's any - (let ((buffer-process (get-buffer-process buffer))) - (when buffer-process - (let ((mark-pos (marker-position (process-mark buffer-process)))) - (process-send-string process - (crdt--format-message - `(process-mark ,crdt--buffer-network-name - ,(crdt--get-id mark-pos) ,mark-pos)))))) + ;; synchronize tracked overlay + (maphash (lambda (k ov) + (let ((meta (overlay-get ov 'crdt-meta))) + (process-send-string + crdt--process + (crdt--format-message (crdt--overlay-add-message + (car k) (cdr k) + (crdt--overlay-metadata-species meta) + (crdt--overlay-metadata-front-advance meta) + (crdt--overlay-metadata-rear-advance meta) + (overlay-start ov) + (overlay-end ov)))) + (cl-loop for (prop value) on (crdt--overlay-metadata-plist meta) by #'cddr + do (process-send-string + crdt--process + (crdt--format-message `(overlay-put ,crdt--buffer-network-name + ,(car k) ,(cdr k) ,prop ,value)))))) + crdt--overlay-table) - (process-send-string process (crdt--format-message `(ready ,crdt--buffer-network-name ,major-mode))))) + (crdt--send-process-mark-maybe nil) + (crdt--send-variables-maybe nil)))) -(defun crdt--greet-client (process) +(defun crdt--greet-client () "Send initial information when a client connects. Those information include the assigned SITE-ID, buffer list, and contact data of other users. -The network process for the client connection is PROCESS." - (let ((crdt--session (process-get process 'crdt-session))) - (cl-pushnew process (crdt--session-network-clients crdt--session)) - (let ((client-id (process-get process 'client-id))) +CRDT--PROCESS should be bound to The network process for the client connection." + (let ((crdt--session (process-get crdt--process 'crdt-session))) + (cl-pushnew crdt--process (crdt--session-network-clients crdt--session)) + (let ((client-id (process-get crdt--process 'client-id))) (unless client-id (unless (< (crdt--session-next-client-id crdt--session) crdt--max-value) (error "Used up client IDs. Need to implement allocation algorithm")) - (process-put process 'client-id (crdt--session-next-client-id crdt--session)) + (process-put crdt--process 'client-id (crdt--session-next-client-id crdt--session)) (setq client-id (crdt--session-next-client-id crdt--session)) - (process-send-string process (crdt--format-message + (process-send-string crdt--process (crdt--format-message `(login ,client-id ,(crdt--session-name crdt--session)))) (cl-incf (crdt--session-next-client-id crdt--session))) - (process-send-string process (crdt--format-message + (process-send-string crdt--process (crdt--format-message (cons 'add (hash-table-keys (crdt--session-buffer-table crdt--session))))) ;; synchronize contact (maphash (lambda (k v) - (process-send-string process + (process-send-string crdt--process (crdt--format-message `(contact ,k ,(crdt--contact-metadata-display-name v) ,(crdt--contact-metadata-host v) ,(crdt--contact-metadata-service v)))) - (process-send-string process + (process-send-string crdt--process (crdt--format-message `(focus ,k ,(crdt--contact-metadata-focused-buffer-name v))))) (crdt--session-contact-table crdt--session)) - (process-send-string process + (process-send-string crdt--process (crdt--format-message `(contact ,(crdt--session-local-id crdt--session) ,(crdt--session-local-name crdt--session)))) - (process-send-string process + (process-send-string crdt--process (crdt--format-message `(focus ,(crdt--session-local-id crdt--session) ,(crdt--session-focused-buffer-name crdt--session)))) - (let ((contact-message `(contact ,client-id ,(process-get process 'client-name) - ,(process-contact process :host) - ,(process-contact process :service)))) - (crdt-process-message contact-message process))))) + (let ((contact-message `(contact ,client-id ,(process-get crdt--process 'client-name) + ,(process-contact crdt--process :host) + ,(process-contact crdt--process :service)))) + (crdt-process-message-1 contact-message))))) -(cl-defgeneric crdt-process-message (message process) "Handle MESSAGE received from PROCESS.") +(define-crdt-message-handler insert (buffer-name crdt-id position-hint content) + (crdt--with-buffer-name buffer-name + (crdt--with-recover + (crdt--remote-insert crdt-id position-hint content))) + (crdt--broadcast-maybe crdt--message-string (process-get crdt--process 'client-id))) -(cl-defmethod crdt-process-message (message process) - (message "Unrecognized message %S from %s:%s." - message (process-contact process :host) (process-contact process :service))) +(define-crdt-message-handler delete (buffer-name position-hint . id-pairs) + (mapc (lambda (p) (rplaca (cdr p) (cadr p))) id-pairs) + (crdt--with-buffer-name buffer-name + (crdt--with-recover + (crdt--remote-delete position-hint id-pairs))) + (crdt--broadcast-maybe crdt--message-string (process-get crdt--process 'client-id))) -(cl-defmethod crdt-process-message ((message (head insert)) process) - (cl-destructuring-bind (buffer-name crdt-id position-hint content) (cdr message) - (crdt--with-buffer-name - buffer-name - (crdt--remote-insert (base64-decode-string crdt-id) position-hint content))) - (crdt--broadcast-maybe (crdt--format-message message) (process-get process 'client-id))) +(define-crdt-message-handler cursor + (buffer-name site-id point-position-hint point-crdt-id mark-position-hint mark-crdt-id) + (crdt--with-buffer-name buffer-name + (crdt--with-recover + (crdt--remote-cursor site-id point-position-hint point-crdt-id + mark-position-hint mark-crdt-id))) + (crdt--broadcast-maybe crdt--message-string (process-get crdt--process 'client-id))) -(cl-defmethod crdt-process-message ((message (head delete)) process) - (crdt--broadcast-maybe (crdt--format-message message) (process-get process 'client-id)) - (cl-destructuring-bind (buffer-name position-hint . id-base64-pairs) (cdr message) - (mapc (lambda (p) (rplaca (cdr p) (base64-decode-string (cadr p)))) id-base64-pairs) - (crdt--with-buffer-name - buffer-name - (crdt--remote-delete position-hint id-base64-pairs)))) +(define-crdt-message-handler get (buffer-name) + (let ((buffer (gethash buffer-name (crdt--session-buffer-table crdt--session)))) + (if (and buffer (buffer-live-p buffer)) + (crdt--sync-buffer-to-client buffer) + (process-send-string crdt--process (crdt--format-message `(remove ,buffer-name)))))) -(cl-defmethod crdt-process-message ((message (head cursor)) process) - (cl-destructuring-bind (buffer-name site-id point-position-hint point-crdt-id - mark-position-hint mark-crdt-id) - (cdr message) - (crdt--with-buffer-name - buffer-name - (crdt--remote-cursor site-id point-position-hint - (and point-crdt-id (base64-decode-string point-crdt-id)) - mark-position-hint - (and mark-crdt-id (base64-decode-string mark-crdt-id))))) - (crdt--broadcast-maybe (crdt--format-message message) (process-get process 'client-id))) - -(cl-defmethod crdt-process-message ((message (head get)) process) - (cl-destructuring-bind (buffer-name) (cdr message) - (let ((buffer (gethash buffer-name (crdt--session-buffer-table crdt--session)))) - (if (and buffer (buffer-live-p buffer)) - (crdt--sync-buffer-to-client buffer process) - (process-send-string process (crdt--format-message `(remove ,buffer-name))))))) - -(cl-defmethod crdt-process-message ((message (head sync)) _process) +(define-crdt-message-handler sync (buffer-name . ids) (unless (crdt--server-p) ; server shouldn't receive this - (cl-destructuring-bind (buffer-name . ids) (cdr message) - (crdt--with-buffer-name - buffer-name - (read-only-mode -1) - (let ((crdt--inhibit-update t)) - (unless crdt--buffer-sync-callback - ;; try to get to the same position after sync, - ;; if crdt--buffer-sync-callback is not set yet - (let ((pos (point))) - (setq crdt--buffer-sync-callback - (lambda () - (goto-char - (max (min pos (point-max)) - (point-max))))))) - (erase-buffer) - (crdt--load-ids ids)))) + (crdt--with-buffer-name buffer-name + (read-only-mode -1) + (let ((crdt--inhibit-update t)) + (unless crdt--buffer-sync-callback + ;; try to get to the same position after sync, + ;; if crdt--buffer-sync-callback is not set yet + (let ((pos (point))) + (setq crdt--buffer-sync-callback + (lambda () + (goto-char + (max (min pos (point-max)) + (point-min))))))) + (erase-buffer) + (crdt--load-ids ids))) (crdt--refresh-buffers-maybe))) -(cl-defmethod crdt-process-message ((message (head ready)) _process) - (unless (crdt--server-p) ; server shouldn't receive this - (cl-destructuring-bind (buffer-name mode) (cdr message) - (crdt--with-buffer-name - buffer-name - (if (fboundp mode) - (unless (eq major-mode mode) - (funcall mode) ; trust your server... - (crdt-mode)) - (message "Server uses %s, but not available locally." mode)) - (when crdt--buffer-sync-callback - (funcall crdt--buffer-sync-callback) - (setq crdt--buffer-sync-callback nil)))))) +(define-crdt-message-handler ready (buffer-name mode) + (unless (crdt--server-p) ; server shouldn't receive this + (crdt--with-buffer-name buffer-name + (unless (fboundp mode) + (when (get mode 'crdt-autoload) + (require (get mode 'crdt-autoload) nil t))) + (if (fboundp mode) + (unless (eq major-mode mode) + (funcall mode) ; trust your server... + (crdt-mode)) + (message "Server uses %s, but not available locally." mode)) + (when crdt--buffer-sync-callback + (funcall crdt--buffer-sync-callback) + (setq crdt--buffer-sync-callback nil))))) -(cl-defmethod crdt-process-message ((message (head add)) _process) - (dolist (buffer-name (cdr message)) +(define-crdt-message-handler error (buffer-name &rest err) + (unless (crdt--server-p) + (if buffer-name + (crdt--with-buffer-name buffer-name + (message "Server side error %s." err) + (crdt--recover)) + (cl-block nil + (message "Server side error %s." err) + (when (eq (car err) 'version) + (if (version< crdt-protocol-version (cadr err)) + (warn "Server uses newer crdt.el protocol (%s>%s). Please update your crdt.el to connect." + (cadr err) crdt-protocol-version) + (warn "Server uses older crdt.el protocol (%s<%s). Please ask to update server." + (cadr err) crdt-protocol-version))) + (crdt-disconnect))))) + +(define-crdt-message-handler add (&rest buffer-names) + (dolist (buffer-name buffer-names) (unless (gethash buffer-name (crdt--session-buffer-table crdt--session)) (puthash buffer-name nil (crdt--session-buffer-table crdt--session))) (crdt--refresh-buffers-maybe))) -(cl-defmethod crdt-process-message ((message (head remove)) process) +(define-crdt-message-handler remove (&rest buffer-names) (let ((saved-session crdt--session)) - (dolist (buffer-name (cdr message)) + (dolist (buffer-name buffer-names) (let ((buffer (gethash buffer-name (crdt--session-buffer-table crdt--session)))) (remhash buffer-name (crdt--session-buffer-table crdt--session)) (when buffer @@ -1314,27 +1632,31 @@ The network process for the client connection is PROCESS." (with-current-buffer buffer (crdt-mode 0) (setq crdt--session nil)))))) - (message "Server stopped sharing %s." - (mapconcat #'identity (cdr message) ", ")) - (let ((crdt--session saved-session)) - (crdt--broadcast-maybe (crdt--format-message message) - (when process (process-get process 'client-id))) - (crdt--refresh-buffers-maybe)))) + (let ((crdt--session saved-session)) + (let ((notify-names + (cl-remove-if-not + (lambda (buffer-name) + (gethash buffer-name (crdt--session-buffer-table crdt--session))) + buffer-names))) + (when notify-names + (warn "Server stopped sharing %s." + (mapconcat #'identity buffer-names ", ")))) + (crdt--broadcast-maybe crdt--message-string (when crdt--process (crdt--client-id))) + (crdt--refresh-buffers-maybe)))) -(cl-defmethod crdt-process-message ((message (head login)) process) - (cl-destructuring-bind (id session-name) (cdr message) - (puthash 0 (crdt--make-contact-metadata nil nil - (process-contact process :host) - (process-contact process :service)) - (crdt--session-contact-table crdt--session)) - (setf (crdt--session-name crdt--session) (concat session-name "@" (crdt--session-name crdt--session))) - (setf (crdt--session-local-id crdt--session) id) - (crdt--refresh-sessions-maybe))) +(define-crdt-message-handler login (id session-name) + (puthash 0 (crdt--make-contact-metadata nil nil + (process-contact crdt--process :host) + (process-contact crdt--process :service)) + (crdt--session-contact-table crdt--session)) + (setf (crdt--session-name crdt--session) (concat session-name "@" (crdt--session-name crdt--session))) + (setf (crdt--session-local-id crdt--session) id) + (crdt--refresh-sessions-maybe)) -(cl-defmethod crdt-process-message ((_message (head leave)) process) - (delete-process process)) +(define-crdt-message-handler leave () + (delete-process crdt--process)) -(cl-defmethod crdt-process-message ((message (head challenge)) _process) +(define-crdt-message-handler challenge (hash) (unless (crdt--server-p) ; server shouldn't receive this (message nil) (let ((password (read-passwd @@ -1342,40 +1664,44 @@ The network process for the client connection is PROCESS." (process-contact (crdt--session-network-process crdt--session) :host) (process-contact (crdt--session-network-process crdt--session) :service))))) (crdt--broadcast-maybe (crdt--format-message - `(hello ,(crdt--session-local-name crdt--session) - ,(gnutls-hash-mac 'SHA1 password (cadr message)))))))) + `(hello ,(crdt--session-local-name crdt--session) ,crdt-protocol-version + ,(gnutls-hash-mac 'SHA1 password hash))))))) -(cl-defmethod crdt-process-message ((message (head contact)) process) - (cl-destructuring-bind - (site-id display-name &optional host service) (cdr message) - (if display-name - (if host - (puthash site-id (crdt--make-contact-metadata - display-name nil host service) - (crdt--session-contact-table crdt--session)) - (let ((existing-item (gethash site-id (crdt--session-contact-table crdt--session)))) - (setf (crdt--contact-metadata-display-name existing-item) display-name))) - (remhash site-id (crdt--session-contact-table crdt--session))) - (crdt--refresh-users-maybe)) - (crdt--broadcast-maybe (crdt--format-message message) (process-get process 'client-id))) +(define-crdt-message-handler contact (site-id display-name &optional host service) + (if display-name + (if host + (puthash site-id (crdt--make-contact-metadata + display-name nil host service) + (crdt--session-contact-table crdt--session)) + (let ((existing-item (gethash site-id (crdt--session-contact-table crdt--session)))) + (setf (crdt--contact-metadata-display-name existing-item) display-name))) + (progn + (when (eq site-id (crdt--session-follow-site-id crdt--session)) + (crdt-stop-follow)) + (remhash site-id (crdt--session-contact-table crdt--session)))) + (crdt--refresh-users-maybe) + (crdt--broadcast-maybe crdt--message-string (process-get crdt--process 'client-id))) -(cl-defmethod crdt-process-message ((message (head focus)) process) - (cl-destructuring-bind - (site-id buffer-name) (cdr message) - (let ((existing-item (gethash site-id (crdt--session-contact-table crdt--session)))) - (setf (crdt--contact-metadata-focused-buffer-name existing-item) buffer-name)) - ;; (when (and (= site-id 0) (not crdt--focused-buffer-name)) - ;; (setq crdt--focused-buffer-name buffer-name) - ;; (switch-to-buffer (gethash buffer-name (crdt--session-buffer-table crdt--session)))) - (crdt--refresh-users-maybe)) - (crdt--broadcast-maybe (crdt--format-message message) (process-get process 'client-id))) +(define-crdt-message-handler focus (site-id buffer-name) + (let ((existing-item (gethash site-id (crdt--session-contact-table crdt--session)))) + (setf (crdt--contact-metadata-focused-buffer-name existing-item) buffer-name)) + ;; (when (and (= site-id 0) (not crdt--focused-buffer-name)) + ;; (setq crdt--focused-buffer-name buffer-name) + ;; (switch-to-buffer (gethash buffer-name (crdt--session-buffer-table crdt--session)))) + (when (eq site-id (crdt--session-follow-site-id crdt--session)) + (crdt--with-buffer-name-pull buffer-name + (switch-to-buffer (current-buffer)) + (let ((ov-pair (gethash site-id crdt--pseudo-cursor-table))) + (when ov-pair (goto-char (overlay-start (car ov-pair))))))) + (crdt--refresh-users-maybe) + (crdt--broadcast-maybe crdt--message-string (process-get crdt--process 'client-id))) (defun crdt--network-filter (process string) "Network filter function for CRDT network processes. Handle received STRING from PROCESS." (unless (and (process-buffer process) (buffer-live-p (process-buffer process))) - (set-process-buffer process (generate-new-buffer "*crdt-server*")) + (set-process-buffer process (generate-new-buffer " *crdt-server*")) (with-current-buffer (process-buffer process) (set-marker (process-mark process) 1))) (with-current-buffer (process-buffer process) @@ -1386,37 +1712,41 @@ Handle received STRING from PROCESS." (insert string) (set-marker (process-mark process) (point)) (goto-char (point-min)) - (let (message) - (while (setq message (ignore-errors (read (current-buffer)))) + (let (message string start (crdt--process process)) + (while (setq start (point) + message (ignore-errors (read (current-buffer)))) (when crdt--log-network-traffic (print message)) - (cl-macrolet ((body () - '(if (or (not (crdt--server-p)) (process-get process 'authenticated)) - (let ((crdt--inhibit-update t)) - (crdt-process-message message process)) - (cl-block nil - (when (eq (car message) 'hello) - (cl-destructuring-bind (name &optional response) (cdr message) - (when (or (not (process-get process 'password)) ; server password is empty - (and response (string-equal response (process-get process 'challenge)))) - (process-put process 'authenticated t) - (process-put process 'client-name name) - (crdt--greet-client process) - (cl-return)))) - (let ((challenge (crdt--generate-challenge))) - (process-put process 'challenge - (gnutls-hash-mac 'SHA1 (substring (process-get process 'password)) challenge)) - (process-send-string process (crdt--format-message `(challenge ,challenge)))))))) - (if debug-on-error (body) - (condition-case err (body) - (error (message "%s error when processing message from %s:%s, disconnecting." err - (process-contact process :host) (process-contact process :service)) - (if (crdt--server-p) - (progn - (delete-process process)) - (crdt--stop-session crdt--session)))))) + (setq string (buffer-substring-no-properties start (point))) (delete-region (point-min) (point)) - (goto-char (point-min))))))) + (goto-char (point-min)) + (condition-case err + (if (or (not (crdt--server-p)) (process-get process 'authenticated)) + (let ((crdt--inhibit-update t)) + (crdt-process-message message string)) + (cl-block nil + (when (eq (car message) 'hello) + (cl-destructuring-bind (name protocol-version &optional response) (cdr message) + (when (version< protocol-version crdt-protocol-version) + (process-send-string process + (crdt--format-message `(error nil version ,crdt-protocol-version))) + (cl-return)) + (when (or (not (process-get process 'password)) ; server password is empty + (and response (string-equal response (process-get process 'challenge)))) + (process-put process 'authenticated t) + (process-put process 'client-name name) + (crdt--greet-client) + (cl-return)))) + (let ((challenge (crdt--generate-challenge))) + (process-put process 'challenge + (gnutls-hash-mac 'SHA1 (substring (process-get process 'password)) challenge)) + (process-send-string process (crdt--format-message `(challenge ,challenge)))))) + ((crdt-unrecognized-message invalid-read-syntax) + (warn "%s error when processing message %s from %s:%s, disconnecting." err message + (process-contact process :host) (process-contact process :service)) + (if (crdt--server-p) + (delete-process process) + (crdt--stop-session crdt--session))))))))) (defun crdt--server-process-sentinel (client _message) (let ((crdt--session (process-get client 'crdt-session))) @@ -1425,18 +1755,19 @@ Handle received STRING from PROCESS." ;; client disconnected (setf (crdt--session-network-clients crdt--session) (delq client (crdt--session-network-clients crdt--session))) - (when (process-buffer client) (kill-buffer (process-buffer client))) ;; generate a clear cursor message and a clear contact message (let* ((client-id (process-get client 'client-id)) (clear-contact-message `(contact ,client-id nil))) - (crdt-process-message clear-contact-message client) - (maphash - (lambda (k _) - (crdt-process-message - `(cursor ,k ,client-id 1 nil 1 nil) - client)) - (crdt--session-buffer-table crdt--session)) - (crdt--refresh-users-maybe))))) + (when client-id ; we only do stuff if actually a CRDT client disconnect, not some spider/scanner etc + (let ((crdt--process client)) + (crdt-process-message-1 clear-contact-message)) + (maphash + (lambda (k _) + (let ((crdt--process client)) + (crdt-process-message-1 `(cursor ,k ,client-id 1 nil 1 nil)))) + (crdt--session-buffer-table crdt--session)) + (crdt--refresh-users-maybe))) + (when (process-buffer client) (kill-buffer (process-buffer client)))))) (defun crdt--client-process-sentinel (process _message) (unless (eq (process-status process) 'open) @@ -1468,33 +1799,19 @@ SESSION-NAME if provided is used in the prompt." (setq crdt--buffer-network-name (buffer-name buffer)) (crdt-mode) (save-excursion - (widen) - (let ((crdt--inhibit-update t)) - (with-silent-modifications - (crdt--local-insert (point-min) (point-max)))) - (crdt--broadcast-maybe - (crdt--format-message `(add - ,crdt--buffer-network-name)))) - (add-hook 'kill-buffer-hook #'crdt-stop-share-buffer nil t) + (save-restriction + (widen) + (let ((crdt--inhibit-update t)) + (with-silent-modifications + (crdt--local-insert (point-min) (point-max)))) + (crdt--broadcast-maybe + (crdt--format-message `(add + ,crdt--buffer-network-name))))) (crdt--refresh-buffers-maybe) (crdt--refresh-sessions-maybe)) (error "Only server can add new buffer"))) -(defsubst crdt--get-session-names (server) - "Get session names for CRDT sessions (as in CRDT--SESSION-LIST). -If SERVER is non-NIL, return the list of names for server sessions. -Otherwise, return the list of names for client sessions." - (let (session-names) - (dolist (session crdt--session-list) - (when (eq (crdt--server-p session) server) - (push (crdt--session-name session) session-names))) - (nreverse session-names))) - -(defsubst crdt--get-session (name) - "Get the CRDT session object with NAME." - (cl-find name crdt--session-list - :test 'equal :key #'crdt--session-name)) - +;;;###autoload (defun crdt-share-buffer (session-name &optional port) "Share the current buffer in the CRDT session with name SESSION-NAME. Create a new one if such a CRDT session doesn't exist. When PORT @@ -1506,7 +1823,12 @@ of the current buffer." (when (and crdt-mode crdt--session) (error "Current buffer is already shared in a CRDT session")) (list (let* ((session-names (crdt--get-session-names t)) - (default-name (concat crdt-default-name ":" (buffer-name (current-buffer)))) + (default-name (if (member crdt-default-session-name session-names) + (cl-loop for i from 1 + for name = (concat crdt-default-session-name "_" (number-to-string i)) + unless (member name session-names) + do (cl-return name)) + crdt-default-session-name)) (session-name (if session-names (completing-read "Choose a server session (create if not exist): " session-names) @@ -1523,15 +1845,17 @@ of the current buffer." (error "Port must be a number")) (crdt--share-buffer (current-buffer) (crdt-new-session port session-name)))))) -(defun crdt-stop-share-buffer () - "Stop sharing the current buffer." - (interactive) - (if crdt--session - (if (crdt--server-p) - (let ((buffer-name crdt--buffer-network-name)) - (let ((remove-message `(remove ,buffer-name))) - (crdt-process-message remove-message nil))) - (message "Only server can stop sharing a buffer.")) +(cl-defun crdt-stop-share-buffer (&optional (session crdt--session) + (network-name crdt--buffer-network-name)) + "Stop sharing buffer with NETWORK-NAME in SESSION." + (interactive (let ((session (crdt--read-session-maybe 'server))) + (list session (crdt--read-buffer-maybe session)))) + (if session + (let ((crdt--session session)) + (if (crdt--server-p) + (let ((remove-message `(remove ,network-name))) + (crdt-process-message-1 remove-message)) + (message "Only server can stop sharing a buffer."))) (message "Not a CRDT shared buffer."))) (defun crdt-new-session (port session-name &optional password display-name) @@ -1540,7 +1864,6 @@ Setup up the server with PASSWORD and assign this Emacs DISPLAY-NAME." (let* ((network-process (make-network-process :name "CRDT Server" :server t - :family 'ipv4 :host "0.0.0.0" :service port :filter #'crdt--network-filter @@ -1569,7 +1892,7 @@ Setup up the server with PASSWORD and assign this Emacs DISPLAY-NAME." :buffer (generate-new-buffer "*Tuntox Proxy*") :command `(,crdt-tuntox-executable - "-C" ,crdt-tuntox-key-path + "-C" ,(expand-file-name crdt-tuntox-key-path) "-f" "/dev/stdin" ; do the filtering for safety sake ,@ (when (and password (> (length password) 0)) `("-s" ,password)))))) @@ -1582,8 +1905,8 @@ Setup up the server with PASSWORD and assign this Emacs DISPLAY-NAME." new-session)) (defun crdt--stop-session (session) - "Kill the CRDT SESSION. -Disconnect if it's a client session, or stop serving if it's a server session." + "Kill the CRDT SESSION." + (interactive (list (crdt--read-session-maybe 'server))) (when (if (and crdt-confirm-disconnect (crdt--server-p session) (crdt--session-network-clients session)) @@ -1616,32 +1939,22 @@ Disconnect if it's a client session, or stop serving if it's a server session." (kill-buffer process-buffer)) (when (and proxy-process (process-live-p proxy-process)) (interrupt-process proxy-process))) - (message "Disconnected."))) + (unless (memq this-command '(crdt-disconnect crdt-stop-session crdt--stop-session)) + (warn "CRDT session %s disconnected." (crdt--session-name session))))) -(defun crdt-stop-session (&optional session-name) - "Stop sharing the session with SESSION-NAME. -If SESSION-NAME is nil, stop sharing the current session." +(defun crdt-stop-session (&optional session) + "Stop sharing the SESSION. +If SESSION is nil, stop sharing the current session." (interactive - (list (completing-read "Choose a server session: " - (crdt--get-session-names t) nil t - (when (and crdt--session (crdt--server-p)) - (crdt--session-name crdt--session))))) - (let ((session (if session-name - (crdt--get-session session-name) - crdt--session))) - (crdt--stop-session session))) + (list (crdt--read-session-maybe 'server))) + (crdt--stop-session (or session crdt--session))) -(defun crdt-copy-url (&optional session-name) - "Copy the url for the session with SESSION-NAME. +(defun crdt-copy-url (&optional session) + "Copy the url for the SESSION. Currently this only work if a tuntox proxy is used." (interactive - (list (completing-read "Choose a server session: " - (crdt--get-session-names t) nil t - (when (and crdt--session (crdt--server-p)) - (crdt--session-name crdt--session))))) - (let* ((session (if session-name - (crdt--get-session session-name) - crdt--session)) + (list (crdt--read-session-maybe 'server))) + (let* ((session (or session crdt--session)) (network-process (crdt--session-network-process session)) (tuntox-process (process-get network-process 'tuntox-process))) (if tuntox-process @@ -1658,21 +1971,16 @@ Currently this only work if a tuntox proxy is used." (message "URL copied.")) (message "No known URL to copy, find out your public IP address yourself!")))) -(defun crdt-disconnect (&optional session-name) - "Disconnect from the session with SESSION-NAME. -If SESSION-NAME is nil, disconnect from the current session." +(defun crdt-disconnect (&optional session) + "Disconnect from client SESSION. +If SESSION is nil, disconnect from the current session." (interactive - (list (completing-read "Choose a client session: " - (crdt--get-session-names nil) nil t - (when (and crdt--session (not (crdt--server-p crdt--session))) - (crdt--session-name crdt--session))))) - (let ((session (if session-name - (crdt--get-session session-name) - crdt--session))) - (crdt--stop-session session))) + (list (crdt--read-session-maybe 'client))) + (crdt--stop-session (or session crdt--session))) (defvar crdt-connect-url-history nil) +;;;###autoload (defun crdt-connect (url &optional display-name) "Connect to a CRDT server running at URL. Open a new buffer to display the shared content. @@ -1697,9 +2005,8 @@ Join with DISPLAY-NAME." (cl-macrolet ((start-session (&body body) `(let* ((network-process (make-network-process :name "CRDT Client" - :buffer (generate-new-buffer "*crdt-client*") + :buffer (generate-new-buffer " *crdt-client*") :host address - :family 'ipv4 :service port :filter #'crdt--network-filter :sentinel #'crdt--client-process-sentinel)) @@ -1714,8 +2021,10 @@ Join with DISPLAY-NAME." (process-put network-process 'crdt-session new-session) (push new-session crdt--session-list) ,@body - (process-send-string network-process - (crdt--format-message `(hello ,(crdt--session-local-name new-session)))) + (process-send-string + network-process + (crdt--format-message + `(hello ,(crdt--session-local-name new-session) ,crdt-protocol-version))) (let ((crdt--session new-session)) (crdt-list-buffers))))) (cond ((equal url-type "tcp") @@ -1724,7 +2033,8 @@ Join with DISPLAY-NAME." (start-session)) ((equal url-type "tuntox") (setq address "127.0.0.1") - (setq port (read-from-minibuffer (format "tuntox proxy port (default %s): " (1+ (url-portspec url))) + (setq port (read-from-minibuffer (format "tuntox proxy port (default %s): " + (1+ (url-portspec url))) nil nil t nil (format "%s" (1+ (url-portspec url))))) (let ((password (read-passwd "tuntox password (empty for no password): "))) (switch-to-buffer-other-window @@ -1805,26 +2115,24 @@ Join with DISPLAY-NAME." (cl-incf (crdt--session-local-clock crdt--session)))) new-overlay)) -(cl-defmethod crdt-process-message ((message (head overlay-add)) process) - (cl-destructuring-bind - (buffer-name site-id logical-clock species - front-advance rear-advance start-hint start-id-base64 end-hint end-id-base64) - (cdr message) - (crdt--with-buffer-name - buffer-name - (let* ((crdt--track-overlay-species nil) - (start (crdt--find-id (base64-decode-string start-id-base64) start-hint front-advance)) - (end (crdt--find-id (base64-decode-string end-id-base64) end-hint rear-advance)) - (new-overlay - (make-overlay start end nil front-advance rear-advance)) - (key (cons site-id logical-clock)) - (meta (crdt--make-overlay-metadata key species - front-advance rear-advance nil))) - (puthash key new-overlay crdt--overlay-table) - (let ((crdt--inhibit-overlay-advices t) - (crdt--modifying-overlay-metadata t)) - (overlay-put new-overlay 'crdt-meta meta))))) - (crdt--broadcast-maybe (crdt--format-message message) (process-get process 'client-id))) +(define-crdt-message-handler overlay-add + (buffer-name site-id logical-clock species + front-advance rear-advance start-hint start-id end-hint end-id) + (crdt--with-buffer-name buffer-name + (crdt--with-recover + (let* ((crdt--track-overlay-species nil) + (start (crdt--find-id start-id start-hint front-advance)) + (end (crdt--find-id end-id end-hint rear-advance)) + (new-overlay + (make-overlay start end nil front-advance rear-advance)) + (key (cons site-id logical-clock)) + (meta (crdt--make-overlay-metadata key species + front-advance rear-advance nil))) + (puthash key new-overlay crdt--overlay-table) + (let ((crdt--inhibit-overlay-advices t) + (crdt--modifying-overlay-metadata t)) + (overlay-put new-overlay 'crdt-meta meta))))) + (crdt--broadcast-maybe crdt--message-string (process-get crdt--process 'client-id))) (defun crdt--move-overlay-advice (orig-fun ov beg end &rest args) (when crdt-mode @@ -1838,30 +2146,29 @@ Join with DISPLAY-NAME." (crdt--format-message `(overlay-move ,crdt--buffer-network-name ,(car key) ,(cdr key) ,beg ,(if front-advance - (base64-encode-string (crdt--get-id beg)) - (crdt--base64-encode-maybe (crdt--get-id (1- beg)))) + (crdt--get-id beg) + (crdt--get-id (1- beg))) ,end ,(if rear-advance - (base64-encode-string (crdt--get-id end)) - (crdt--base64-encode-maybe (crdt--get-id (1- end)))))))))))) + (crdt--get-id end) + (crdt--get-id (1- end))))))))))) (apply orig-fun ov beg end args)) -(cl-defmethod crdt-process-message ((message (head overlay-move)) _process) - (cl-destructuring-bind (buffer-name site-id logical-clock - start-hint start-id-base64 end-hint end-id-base64) - (cdr message) - (crdt--with-buffer-name - buffer-name - (let* ((key (cons site-id logical-clock)) - (ov (gethash key crdt--overlay-table))) - (when ov - (let* ((meta (overlay-get ov 'crdt-meta)) - (front-advance (crdt--overlay-metadata-front-advance meta)) - (rear-advance (crdt--overlay-metadata-rear-advance meta)) - (start (crdt--find-id (base64-decode-string start-id-base64) start-hint front-advance)) - (end (crdt--find-id (base64-decode-string end-id-base64) end-hint rear-advance))) - (let ((crdt--inhibit-overlay-advices t)) - (move-overlay ov start end))))))) - (crdt--broadcast-maybe (crdt--format-message message) nil)) +(define-crdt-message-handler overlay-move + (buffer-name site-id logical-clock + start-hint start-id end-hint end-id) + (crdt--with-buffer-name buffer-name + (crdt--with-recover + (let* ((key (cons site-id logical-clock)) + (ov (gethash key crdt--overlay-table))) + (when ov + (let* ((meta (overlay-get ov 'crdt-meta)) + (front-advance (crdt--overlay-metadata-front-advance meta)) + (rear-advance (crdt--overlay-metadata-rear-advance meta)) + (start (crdt--find-id start-id start-hint front-advance)) + (end (crdt--find-id end-id end-hint rear-advance))) + (let ((crdt--inhibit-overlay-advices t)) + (move-overlay ov start end))))))) + (crdt--broadcast-maybe crdt--message-string nil)) (defun crdt--delete-overlay-advice (orig-fun ov) (unless crdt--inhibit-overlay-advices @@ -1874,17 +2181,16 @@ Join with DISPLAY-NAME." `(overlay-remove ,crdt--buffer-network-name ,(car key) ,(cdr key))))))))) (funcall orig-fun ov)) -(cl-defmethod crdt-process-message ((message (head overlay-remove)) process) - (cl-destructuring-bind (buffer-name site-id logical-clock) (cdr message) - (crdt--with-buffer-name - buffer-name - (let* ((key (cons site-id logical-clock)) - (ov (gethash key crdt--overlay-table))) - (when ov - (remhash key crdt--overlay-table) - (let ((crdt--inhibit-overlay-advices t)) - (delete-overlay ov)))))) - (crdt--broadcast-maybe (crdt--format-message message) (process-get process 'client-id))) +(define-crdt-message-handler overlay-remove (buffer-name site-id logical-clock) + (crdt--with-buffer-name buffer-name + (crdt--with-recover + (let* ((key (cons site-id logical-clock)) + (ov (gethash key crdt--overlay-table))) + (when ov + (remhash key crdt--overlay-table) + (let ((crdt--inhibit-overlay-advices t)) + (delete-overlay ov)))))) + (crdt--broadcast-maybe crdt--message-string (process-get crdt--process 'client-id))) (defun crdt--overlay-put-advice (orig-fun ov prop value) (unless (and (eq prop 'crdt-meta) @@ -1893,68 +2199,343 @@ Join with DISPLAY-NAME." (unless crdt--inhibit-overlay-advices (let ((meta (overlay-get ov 'crdt-meta))) (when meta - (setf (crdt--overlay-metadata-plist meta) (plist-put (crdt--overlay-metadata-plist meta) prop value)) + (setf (crdt--overlay-metadata-plist meta) + (plist-put (crdt--overlay-metadata-plist meta) prop value)) (let* ((key (crdt--overlay-metadata-lamport-timestamp meta)) - (message (crdt--format-message `(overlay-put ,crdt--buffer-network-name - ,(car key) ,(cdr key) ,prop ,value)))) - (condition-case nil - (progn ; filter non-readable object - (read-from-string message) - (crdt--broadcast-maybe message)) - (invalid-read-syntax))))))) + (message (crdt--format-message + `(overlay-put ,crdt--buffer-network-name + ,(car key) ,(cdr key) ,prop ,(crdt--readable-encode value))))) + (crdt--broadcast-maybe message)))))) (funcall orig-fun ov prop value))) -(cl-defmethod crdt-process-message ((message (head overlay-put)) process) - (cl-destructuring-bind (buffer-name site-id logical-clock prop value) (cdr message) - (crdt--with-buffer-name - buffer-name - (let ((ov (gethash (cons site-id logical-clock) crdt--overlay-table))) - (when ov - (let ((meta (overlay-get ov 'crdt-meta))) - (setf (crdt--overlay-metadata-plist meta) - (plist-put (crdt--overlay-metadata-plist meta) prop value)) - (when (memq (crdt--overlay-metadata-species meta) crdt--enabled-overlay-species) - (let ((crdt--inhibit-overlay-advices t)) - (overlay-put ov prop value)))))))) - (crdt--broadcast-maybe (crdt--format-message message) nil)) +(define-crdt-message-handler overlay-put (buffer-name site-id logical-clock prop value) + (setq value (crdt--readable-decode value)) + (crdt--with-buffer-name buffer-name + (crdt--with-recover + (let ((ov (gethash (cons site-id logical-clock) crdt--overlay-table))) + (when ov + (let ((meta (overlay-get ov 'crdt-meta))) + (setf (crdt--overlay-metadata-plist meta) + (plist-put (crdt--overlay-metadata-plist meta) prop value)) + (when (memq (crdt--overlay-metadata-species meta) crdt--enabled-overlay-species) + (let ((crdt--inhibit-overlay-advices t)) + (overlay-put ov prop value)))))))) + (crdt--broadcast-maybe crdt--message-string nil)) (advice-add 'make-overlay :around #'crdt--make-overlay-advice) - (advice-add 'move-overlay :around #'crdt--move-overlay-advice) - (advice-add 'delete-overlay :around #'crdt--delete-overlay-advice) - (advice-add 'overlay-put :around #'crdt--overlay-put-advice) -;;; Org integration +;;; Auxillary autoload -(define-minor-mode crdt-org-sync-overlay-mode "" - nil " Sync Org Overlay" nil - (if crdt-org-sync-overlay-mode - (progn - (save-excursion - (widen) - ;; heuristic to remove existing org overlays - (cl-loop for ov in (overlays-in (point-min) (point-max)) - do (when (memq (overlay-get ov 'invisible) - '(outline org-hide-block)) - (delete-overlay ov)))) - (crdt--enable-overlay-species 'org)) - (crdt--disable-overlay-species 'org))) +(defun crdt-register-autoload (mode feature) + "Register for autoloading FEATURE before CRDT enforce major MODE." + (put mode 'crdt-autoload feature)) -(defun crdt--org-overlay-advice (orig-fun &rest args) - (if crdt-org-sync-overlay-mode - (let ((crdt--track-overlay-species 'org)) - (apply orig-fun args)) - (apply orig-fun args))) +;;; Remote Command -(cl-loop for command in '(org-cycle org-shifttab) - do (advice-add command :around #'crdt--org-overlay-advice)) +(defun crdt--assemble-state-list (states) + (let (result) + (cl-labels ((process (entry) + (cl-ecase entry + ((region) (mapc #'process '(point mark mark-active transient-mark-mode))) + ((point) (push (list entry (crdt--get-id (point)) (point)) result)) + ((mark) (push (list entry (crdt--get-id (mark)) (mark)) result)) + ((mark-active transient-mark-mode last-command-event) + (push (list entry (crdt--readable-encode (symbol-value entry))) result))))) + (mapc #'process states)) + result)) + +(defun crdt--apply-state-list (state-list) + (let (vars vals) + (dolist (entry state-list) + (cl-case (car entry) + ((point) (goto-char (apply #'crdt--id-to-pos (cdr entry)))) + ((mark) (set-mark (apply #'crdt--id-to-pos (cdr entry)))) + ((mark-active transient-mark-mode last-command-event) + (push (car entry) vars) + (push (crdt--readable-decode (cadr entry)) vals)))) + (cons vars vals))) + +(defvar crdt--remote-call-spawn-site nil + "The site where current remote call (if any) is orignally called.") + +(define-crdt-message-handler command + (buffer-name spawn-site-id site-id logical-clock + state-list command-symbol &rest args) + (crdt--with-buffer-name buffer-name + (save-mark-and-excursion + (let ((bindings (crdt--apply-state-list state-list))) + (cl-progv (car bindings) (cdr bindings) + (let* ((crdt--inhibit-update nil) + (crdt--remote-call-spawn-site spawn-site-id) + (return-message + (if (get command-symbol 'crdt-allow-remote-call) + (condition-case err + (list t + (apply command-symbol (mapcar #'crdt--readable-decode args))) + (error (list nil (car err) (crdt--readable-encode (cdr err))))) + (list nil 'crdt-access-denied))) + (msg (crdt--format-message + `(return ,site-id ,logical-clock + ,(crdt--assemble-state-list (get command-symbol 'crdt-command-out-states)) + ,@return-message)))) + (crdt--log-send-network-traffic msg) + (process-send-string crdt--process msg))))))) + +(defvar crdt--return-message-table (make-hash-table)) + +(define-crdt-message-handler return (site-id logical-clock state-list success-p &rest return-values) + (when (eq site-id (crdt--session-local-id crdt--session)) + (puthash logical-clock (cl-list* state-list success-p (crdt--readable-decode return-values)) + crdt--return-message-table))) + +(defun crdt--make-remote-call (spawn-site-id function-symbol in-states args) + "Send remote call request (a command type message) for FUNCTION-SYMBOL. +SPAWN-SITE-ID is the site where +the series (if any) of remote calls originally started. +Assemble state list for items in IN-STATES. +Request for calling FUNCTION-SYMBOL with ARGS." + (let* ((site-id (crdt--session-local-id crdt--session)) + (logical-clock (crdt--session-local-clock crdt--session)) + (msg (crdt--format-message + `(command ,crdt--buffer-network-name ,spawn-site-id + ,site-id ,logical-clock + ,(crdt--assemble-state-list in-states) + ,function-symbol ,@(mapcar #'crdt--readable-encode args))))) + (crdt--log-send-network-traffic msg) + (process-send-string (crdt--session-network-process crdt--session) msg) + (cl-incf (crdt--session-local-clock crdt--session)) + (while (not (gethash logical-clock crdt--return-message-table)) + (sleep-for 0.1) + (thread-yield)) + (let ((return-message (gethash logical-clock crdt--return-message-table))) + (remhash logical-clock crdt--return-message-table) + (cl-destructuring-bind (state-list success-p &rest return-values) return-message + (crdt--apply-state-list state-list) + (if success-p + (car return-values) + (apply #'signal return-values)))))) + +(defun crdt--make-remote-command-advice (function-symbol in-states) + (lambda (orig-fun &rest args) + (if (and crdt--session (not (crdt--server-p))) + (crdt--make-remote-call (crdt--session-local-id crdt--session) + function-symbol in-states args) + (apply orig-fun args)))) + +(defun crdt-register-remote-command (command-symbol &optional in-states out-states) + "Register COMMAND-SYMBOL as a remote command. +Allow remote calls to COMMAND-SYMBOL. +Delegate calls to COMMAND-SYMBOL at client side to the server. +Assume that COMMAND-SYMBOL, when invoked, +make use of no more states other than those in IN-STATES. +After executing the command on the server, +OUT-STATES are sent back to the client." + (put command-symbol 'crdt-allow-remote-call t) + (put command-symbol 'crdt-command-out-states out-states) + (advice-add command-symbol :around (crdt--make-remote-command-advice command-symbol in-states) + '((name . crdt-remote-command-advice)))) + +(defun crdt-unregister-remote-command (command-symbol) + "Unregister COMMAND-SYMBOL as a remote command. +Stop allowing remote calls to COMMAND-SYMBOL." + (cl-remprop command-symbol 'crdt-allow-remote-call) + (advice-remove command-symbol 'crdt-remote-command-advice)) + +(defun crdt-register-remote-commands (command-entries) + "Register a list of remote commands according to COMMAND-ENTRIES. +Each item in COMMAND-ENTRIES should have the form (COMMAND-SYMBOL &optional IN-STATES OUT-STATES)." + (dolist (entry command-entries) + (apply #'crdt-register-remote-command entry))) + +(defun crdt-unregister-remote-commands (command-entries) + "Unregister a list of remote commands according to COMMAND-ENTRIES. +Required form of COMMAND-ENTRIES is the same as that of CRDT-REGISTER-REMOTE-COMMANDS." + (dolist (entry command-entries) + (crdt-unregister-remote-command (car entry)))) + +(defun crdt--make-remote-interaction-advice (function-symbol) + (lambda (orig-fun &rest args) + (if (and crdt--process + (not (eq crdt--remote-call-spawn-site (crdt--session-local-id crdt--session)))) + ;; Is the above condition correct? + ;; We must make sure we don't bind crdt--process AND call interaction command + ;; in any circumstances except inside a remote command call + (crdt--make-remote-call crdt--remote-call-spawn-site function-symbol nil args) + (apply orig-fun args)))) + +(defun crdt-register-interaction-function (function-symbol &rest states) + "Register FUNCTION-SYMBOL as a remote interaction function. +Allow remote calls to FUNCTION-SYMBOL. +Delegate calls to FUNCTION-SYMBOL inside some remote command call +back to the site where the remote command is originally invoked. +Assume that COMMAND-SYMBOL, when invoked, +make use of no more states other than those in STATES." + (put function-symbol 'crdt-allow-remote-call t) + (advice-add function-symbol :around (apply #'crdt--make-remote-interaction-advice function-symbol states) + '((name . crdt-remote-interaction-advice)))) + +(defun crdt-unregister-interaction-function (function-symbol) + "Unregister FUNCTION-SYMBOL as a remote interaction function. +Stop allowing remote calls to FUNCTION-SYMBOL." + (cl-remprop function-symbol 'crdt-allow-remote-call) + (advice-remove function-symbol 'crdt-remote-interaction-advice)) + +(crdt-register-interaction-function 'read-from-minibuffer) + +;;; Buffer local variables + +(defvar-local crdt-variables nil) + +(cl-defun crdt--send-variables-maybe (&optional (incremental t)) + (dolist (var crdt-variables) + (let ((sender (car (get var 'crdt-variable-scheme)))) + (let ((msg (funcall sender var incremental))) + (unless (eq msg 'crdt-unchanged) + (crdt--broadcast-maybe (crdt--format-message + `(var ,crdt--buffer-network-name ,var ,@(crdt--readable-encode msg))))))))) + +(define-crdt-message-handler var (buffer-name variable-symbol . args) + (crdt--with-buffer-name buffer-name + (funcall (cdr (get variable-symbol 'crdt-variable-scheme)) + variable-symbol args))) + +;; Tree diff +;; We use it to provide an incremental variable sender/receiver for general Lisp data structure. +;; Currently we use a naive algorithm which should work reasonably well +;; when there are few shape changes. +;; The naive algorithm also runs in linear time and space. +;; Sophiscated algorithms that computes minimal editing distance are usually much more expensive. + +(defsubst crdt--exhaust-thunk (thunk) + "Keep forcing THUNK until it no longer returns a function. +For poor man's TCO." + (while (functionp thunk) + (setq thunk (funcall thunk)))) + +(defun crdt--diff (old new) + "Compute tree diff between OLD and NEW. +The result DIFF can be used in (CRDT--NAPPLY-DIFF OLD DIFF) to reproduce NEW." + (let (result) + (cl-labels + ;; we could do a running length encoding of path + ;; not bothering that for now + ((process (path old new vindex) + (cl-typecase old + (cons (if (consp new) + (progn + (crdt--exhaust-thunk + (process (concat path "a") (car old) (car new) 0)) + (lambda () (process (concat path "d") (cdr old) (cdr new) 0))) + (push (list path new) result))) + (vector (cond ((not (vectorp new)) (push (list path new) result)) + ((>= vindex (length old)) + (unless (= (length old) (length new)) + (push (list path (substring new vindex)) result))) + ((>= vindex (length new)) + (push (list path nil) result)) + (t + (crdt--exhaust-thunk + (process (concat path "a") (aref old vindex) (aref new vindex) 0)) + (lambda () (process (concat path "d") old new (1+ vindex)))))) + (t (unless (eql old new) (push (list path new) result)))))) + (crdt--exhaust-thunk (process nil old new 0)) + result))) + +(defun crdt--napply-diff (old diff) + "Destructively apply DIFF produced by CRDT--DIFF to OLD." + ;; we could do them in one pass + ;; not bothering that for now + (dolist (update diff) + (cl-destructuring-bind (path new) update + (let ((cursor + (lambda (msg &optional data) + (cl-ecase msg + ((get) old) + ((set) (setq old data)) + ((vindex) 0))))) + (dotimes (path-index (length path)) + (let ((cursor-data (funcall cursor 'get))) + (cl-ecase (aref path path-index) + ((?a) + (cl-etypecase cursor-data + (cons (setq cursor + (lambda (msg &optional data) + (cl-ecase msg + ((get) (car cursor-data)) + ((set) (rplaca cursor-data data)) + ((vindex) 0))))) + (vector (setq cursor + (let ((vindex (funcall cursor 'vindex))) + (lambda (msg &optional data) + (cl-ecase msg + ((get) (aref cursor-data vindex)) + ((set) (aset cursor-data vindex data)) + ((vindex) 0)))))))) + ((?d) + (cl-etypecase cursor-data + (cons + (setq cursor + (lambda (msg &optional data) + (cl-ecase msg + ((get) (cdr cursor-data)) + ((set) (rplacd cursor-data data)) + ((vindex) 0))))) + (vector (setq cursor + (let ((saved-cursor cursor) + (vindex (1+ (funcall cursor 'vindex)))) + (lambda (msg &optional data) + (cl-ecase msg + ((get) cursor-data) + ((set) + (lambda () + (funcall saved-cursor 'set + (if data + (vconcat cursor-data data) + (substring cursor-data 0 vindex))))) + ((vindex) vindex))))))))))) + (crdt--exhaust-thunk (funcall cursor 'set new))))) + old) + +(defun crdt--diff-server-variable-sender (var incremental) + (if (crdt--server-p) + (if incremental + (let ((diff (crdt--diff (get var 'crdt--diff-cache) (symbol-value var)))) + (if diff + (progn (put var 'crdt--diff-cache (copy-tree (symbol-value var) t)) + diff) + 'crdt-unchanged)) + (list (list "" (symbol-value var)))) + 'crdt-unchanged)) + +(defun crdt--diff-server-variable-receiver (var args) + (unless (crdt--server-p) + (set var (crdt--napply-diff (symbol-value var) args)))) + +(defvar crdt-variable-scheme-diff-server (cons #'crdt--diff-server-variable-sender #'crdt--diff-server-variable-receiver)) + +(defun crdt-register-variable (variable scheme) + (add-to-list 'crdt-variables variable) + (put variable 'crdt-variable-scheme + (if (symbolp scheme) (symbol-value scheme) scheme))) + +(defun crdt-unregister-variable (variable) + (delq variable crdt-variables)) + +(defun crdt-register-variables (variable-entries) + (dolist (entry variable-entries) + (apply #'crdt-register-variable entry))) + +(defun crdt-unregister-variables (variable-entries) + (dolist (entry variable-entries) + (crdt-unregister-variable (car entry)))) ;;; pseudo process + (cl-defstruct (crdt--pseudo-process (:constructor crdt--make-pseudo-process)) - buffer - mark) + buffer mark) (defun crdt--pseudo-process-send-string (pseudo-process string) (with-current-buffer (crdt--pseudo-process-buffer pseudo-process) @@ -1972,12 +2553,14 @@ Join with DISPLAY-NAME." (funcall orig-func process start end))) (defun crdt--get-buffer-process-advice (orig-func buffer) - (and buffer - (setq buffer (get-buffer buffer)) - (with-current-buffer buffer - (if (and crdt--session (not (crdt--server-p))) - crdt--buffer-pseudo-process - (funcall orig-func buffer))))) + (or (funcall orig-func buffer) + (and buffer + (setq buffer (get-buffer buffer)) + (buffer-live-p buffer) + (with-current-buffer buffer + (or (funcall orig-func buffer) + (and crdt--session (not (crdt--server-p)) + crdt--buffer-pseudo-process)))))) (defun crdt--get-process-advice (orig-func name) (if (crdt--pseudo-process-p name) @@ -1994,33 +2577,36 @@ Join with DISPLAY-NAME." process (funcall orig-func process))) -(cl-defmethod crdt-process-message ((message (head process-mark)) process) - (cl-destructuring-bind (buffer-name crdt-id position-hint) (cdr message) - (crdt--with-buffer-name - buffer-name - (save-excursion - (goto-char (crdt--id-to-pos crdt-id position-hint)) - (let ((buffer-process (get-buffer-process (current-buffer)))) - (if buffer-process - (progn (set-marker (process-mark buffer-process) (point)) - (setq crdt--last-process-mark-id crdt-id) - (crdt--broadcast-maybe (crdt--format-message message) nil)) - (unless (crdt--server-p) - (setq crdt--buffer-pseudo-process - (crdt--make-pseudo-process :buffer (current-buffer) :mark (point-marker))) - (setq crdt--last-process-mark-id crdt-id)))))))) +(define-crdt-message-handler process-mark (buffer-name crdt-id position-hint) + (crdt--with-buffer-name buffer-name + (crdt--with-recover + (save-excursion + (goto-char (crdt--id-to-pos crdt-id position-hint)) + (let ((buffer-process (get-buffer-process (current-buffer)))) + (if buffer-process + (progn (set-marker (process-mark buffer-process) (point)) + (setq crdt--last-process-mark-id crdt-id) + (crdt--broadcast-maybe crdt--message-string + (process-get crdt--process 'client-id))) + (unless (crdt--server-p) + (setq crdt--buffer-pseudo-process + (crdt--make-pseudo-process :buffer (current-buffer) :mark (point-marker))) + (setq crdt--last-process-mark-id crdt-id)))))))) -(defun crdt--send-process-mark-maybe () +(cl-defun crdt--send-process-mark-maybe (&optional (lazy t)) (let ((buffer-process (get-buffer-process (current-buffer)))) (when buffer-process - (let* ((mark-pos (marker-position (process-mark buffer-process))) - (current-id (crdt--get-id mark-pos))) - (unless (string-equal crdt--last-process-mark-id current-id) - (setq crdt--last-process-mark-id current-id) - (crdt--broadcast-maybe - (crdt--format-message - `(process-mark ,crdt--buffer-network-name - ,current-id ,mark-pos)))))))) + (let* ((mark (process-mark buffer-process))) + (when mark + (let* ((mark-pos (marker-position mark))) + (when mark-pos + (let* ((current-id (crdt--get-id mark-pos))) + (unless (and lazy (string-equal crdt--last-process-mark-id current-id)) + (setq crdt--last-process-mark-id current-id) + (crdt--broadcast-maybe + (crdt--format-message + `(process-mark ,crdt--buffer-network-name + ,current-id ,mark-pos)))))))))))) (defun crdt--process-status-advice (orig-func process) (if (crdt--pseudo-process-p process) @@ -2051,26 +2637,187 @@ Join with DISPLAY-NAME." nil (funcall orig-func process func))) -(advice-add 'process-send-string :around #'crdt--process-send-string-advice) -(advice-add 'process-send-region :around #'crdt--process-send-region-advice) -(advice-add 'processp :around #'crdt--processp-advice) -(advice-add 'get-buffer-process :around #'crdt--get-buffer-process-advice) -(advice-add 'get-process :around #'crdt--get-process-advice) -(advice-add 'process-status :around #'crdt--process-status-advice) -(advice-add 'process-buffer :around #'crdt--process-buffer-advice) -(advice-add 'process-mark :around #'crdt--process-mark-advice) -(advice-add 'delete-process :around #'crdt--delete-process-advice) -(advice-add 'process-name :around #'crdt--process-name-advice) -(advice-add 'process-sentinel :around #'crdt--process-sentinel/filter-advice) -(advice-add 'process-filter :around #'crdt--process-sentinel/filter-advice) -(advice-add 'set-process-sentinel :around #'crdt--set-process-sentinel/filter-advice) -(advice-add 'set-process-filter :around #'crdt--set-process-sentinel/filter-advice) +(defun crdt--process-query-on-exit-flag-advice (orig-func process) + (unless (crdt--pseudo-process-p process) + (funcall orig-func process))) -(cl-defmethod crdt-process-message ((message (head process)) process) - (cl-destructuring-bind (buffer-name string) (cdr message) - (crdt--with-buffer-name - buffer-name - (process-send-string (get-buffer-process (current-buffer)) string)))) +(defun crdt--set-process-query-on-exit-flag-advice (orig-func process) + (unless (crdt--pseudo-process-p process) + (funcall orig-func process))) + +(defvar crdt--process-advice-alist + '((process-send-string . crdt--process-send-string-advice) + (process-send-region . crdt--process-send-region-advice) + (processp . crdt--processp-advice) + (get-buffer-process . crdt--get-buffer-process-advice) + (get-process . crdt--get-process-advice) + (process-status . crdt--process-status-advice) + (process-buffer . crdt--process-buffer-advice) + (process-mark . crdt--process-mark-advice) + (delete-process . crdt--delete-process-advice) + (process-name . crdt--process-name-advice) + (process-sentinel . crdt--process-sentinel/filter-advice) + (process-filter . crdt--process-sentinel/filter-advice) + (set-process-sentinel . crdt--set-process-sentinel/filter-advice) + (set-process-filter . crdt--set-process-sentinel/filter-advice) + (process-query-on-exit-flag . crdt--process-query-on-exit-flag-advice) + (process-set-query-on-exit-flag . crdt--set-process-query-on-exit-flag-advice))) + +(defun crdt--install-process-advices () + "Globally enable advices for simulating remote buffer process. +Those advices seem to possibly interfere with other packages. +Use CRDT--UNINSTALL-PROCESS-ADVICES to disable those advices for the rescue." + (dolist (pair crdt--process-advice-alist) + (advice-add (car pair) :around (cdr pair)))) + +(defun crdt--uninstall-process-advices () + "Globally disable advices for simulating remote buffer process." + (dolist (pair crdt--process-advice-alist) + (advice-remove (car pair) (cdr pair)))) + +(crdt--install-process-advices) + +(define-crdt-message-handler process (buffer-name string) + (crdt--with-buffer-name buffer-name + (process-send-string (get-buffer-process (current-buffer)) string))) + +;;; Built-in package integrations + +;; Org +(define-minor-mode crdt-org-sync-overlay-mode + "Minor mode to synchronize hidden `org-mode' subtrees." + :lighter " Sync Org Overlay" + (if crdt-org-sync-overlay-mode + (progn + (save-excursion + (save-restriction + (widen) + ;; heuristic to remove existing org overlays + (cl-loop for ov in (overlays-in (point-min) (point-max)) + do (when (memq (overlay-get ov 'invisible) + '(outline org-hide-block)) + (delete-overlay ov))))) + (crdt--enable-overlay-species 'org)) + (crdt--disable-overlay-species 'org))) + +(defun crdt--org-overlay-advice (orig-fun &rest args) + (if crdt-org-sync-overlay-mode + (let ((crdt--track-overlay-species 'org)) + (apply orig-fun args)) + (apply orig-fun args))) + +(cl-loop for command in '(org-cycle org-shifttab) + do (advice-add command :around #'crdt--org-overlay-advice)) + +;; xscheme +(defvar crdt-xscheme-command-entries + '((xscheme-send-region (region)) + (xscheme-send-definition (point)) + (xscheme-send-previous-expression (point)) + (xscheme-send-next-expression (point)) + (xscheme-send-current-line (point)) + (xscheme-send-buffer) + (xscheme-send-char) + (xscheme-delete-output) + (xscheme-send-breakpoint-interrupt) + (xscheme-send-proceed) + (xscheme-send-control-g-interrupt) + (xscheme-send-control-u-interrupt) + (xscheme-send-control-x-interrupt) + (scheme-debugger-self-insert (last-command-event)))) + +(crdt-register-remote-commands crdt-xscheme-command-entries) +;; xscheme doesn't use standard DEFINE-*-MODE facility +;; and doesn't call after-change-major-mode-hook. +;; Therefore we have to hack. +(advice-add 'scheme-interaction-mode-initialize :after 'crdt--after-change-major-mode) +(advice-add 'scheme-debugger-mode-initialize :after + (lambda () ;; haxxxx!!!! + (let ((major-mode 'scheme-debugger-mode-initialize)) + (crdt--after-change-major-mode)))) +;; I can't get input prompt from debugger to pop up at the right place. +;; Because it's done asynchronously in process filter, +;; and there seems to be no way to know the correct SPAWN-SITE-ID. + +;; comint +(require 'ring) +(defvar comint-input-ring) +(defvar comint-input-ignoredups) +(defvar comint-input-ring-size) +(defvar comint-input-ring-file-name) + +(defvar crdt-comint-command-entries + '((comint-send-input (point) (point)) + (comint-send-region (region) (region)) + (comint-send-eof (point)))) + +(crdt-register-remote-commands crdt-comint-command-entries) + +(crdt-register-autoload 'shell-mode 'shell) +(crdt-register-autoload 'inferior-scheme-mode 'cmuscheme) +(crdt-register-autoload 'inferior-python-mode 'python) +(crdt-register-autoload 'prolog-inferior-mode 'prolog) +(crdt-register-autoload 'inferior-lisp-mode 'inf-lisp) + +(put 'comint-input-ring 'crdt-variable-scheme crdt-variable-scheme-diff-server) + +(defcustom crdt-comint-share-input-history 'censor + "Share comint input history. +If the value is 'censor, +show only input history generated during a CRDT session to its peers, +Merge with history generated before the session after the buffer is no longer shared." + :type '(choice boolean (const censor))) + +(defvar-local crdt--comint-saved-input-ring nil) + +(defun crdt--merge-ring (old-ring delta-ring nodups) + "Construct a new ring by merging OLD-RING and DELTA-RING. +If NODUPS is non-nil, don't duplicate existing items in OLD-RING. +This procedure is non-destructive." + (if delta-ring + (let ((old-ring (copy-tree old-ring t))) + (cl-loop for i from (1- (ring-length delta-ring)) downto 0 + for item = (ring-ref delta-ring i) + do (if nodups + (let ((index (ring-member old-ring item))) + (when index + (ring-remove old-ring index)) + (ring-insert old-ring item)) + (ring-insert old-ring item))) + old-ring) + old-ring)) + +(defsubst crdt--comint-effective-ring () + (if crdt--comint-saved-input-ring + (crdt--merge-ring crdt--comint-saved-input-ring comint-input-ring comint-input-ignoredups) + comint-input-ring)) + +(defun crdt--comint-mode-hook () + (when (derived-mode-p 'comint-mode) + (if crdt-mode + (progn + (add-to-list 'crdt--enabled-text-properties 'field) + (add-to-list 'crdt--enabled-text-properties 'front-sticky) + (add-to-list 'crdt--enabled-text-properties 'rear-nonsticky) + (if (crdt--server-p) + (when crdt-comint-share-input-history + (crdt-register-variable 'comint-input-ring crdt-variable-scheme-diff-server) + (when (eq crdt-comint-share-input-history 'censor) + (cl-shiftf crdt--comint-saved-input-ring comint-input-ring + (make-ring comint-input-ring-size)))) + (crdt-register-variable 'comint-input-ring crdt-variable-scheme-diff-server) + (setq comint-input-ring-file-name nil))) + (setq comint-input-ring (crdt--comint-effective-ring) + crdt--comint-saved-input-ring nil)))) + +(defun crdt--comint-write-input-ring-advice (orig-func) + (if crdt-mode + (let ((comint-input-ring (crdt--comint-effective-ring))) + (funcall orig-func)) + (funcall orig-func))) + +(add-hook 'comint-mode-hook #'crdt--comint-mode-hook) +(add-hook 'crdt-mode-hook #'crdt--comint-mode-hook) (provide 'crdt) ;;; crdt.el ends here diff --git a/lisp/ctable.el b/lisp/ctable.el index e97924b4..69497263 100644 --- a/lisp/ctable.el +++ b/lisp/ctable.el @@ -1,11 +1,13 @@ -;;; ctable.el --- Table component for Emacs Lisp +;;; ctable.el --- Table component for Emacs Lisp -*- lexical-binding: t; -*- -;; Copyright (C) 2011, 2012, 2013, 2014 SAKURAI Masashi +;; Copyright (C) 2011-2021 SAKURAI Masashi ;; Author: SAKURAI Masashi ;; URL: https://github.com/kiwanami/emacs-ctable -;; Package-Version: 20171006.11 -;; Version: 0.1.2 +;; Package-Version: 20210128.629 +;; Package-Commit: 48b73742757a3ae5736d825fe49e00034cc453b5 +;; Version: 0.1.3 +;; Package-Requires: ((emacs "24.3") (cl-lib "0.5")) ;; Keywords: table ;; This program is free software; you can redistribute it and/or modify @@ -42,7 +44,7 @@ ;;; Code: -(require 'cl) +(require 'cl-lib) (declare-function popup-tip "popup") (declare-function pos-tip-show "pos-tip") @@ -50,7 +52,7 @@ ;;; Models and Parameters -(defstruct ctbl:model +(cl-defstruct ctbl:model "Table model structure data : Table data as a list of rows. A row contains a list of columns. @@ -62,7 +64,7 @@ sort-state : The current sort order as a list of column indexes. data column-model sort-state) -(defstruct ctbl:async-model +(cl-defstruct ctbl:async-model "Asynchronous data model request : Data request function which receives 4 arguments (begin-num length fn(row-list) fe(errmsg)). @@ -80,7 +82,7 @@ For forward compatibility, these callback functions should have a `&rest' keywor request (init-num 20) (more-num 20) reset cancel) -(defstruct ctbl:cmodel +(cl-defstruct ctbl:cmodel "Table column model structure title : title string. @@ -96,7 +98,7 @@ click-hooks : a list of functions for header clicking with two arguments (click-hooks '(ctbl:cmodel-sort-action))) -(defstruct ctbl:param +(cl-defstruct ctbl:param "Rendering parameters display-header : if t, display the header row with column models. @@ -209,14 +211,14 @@ Emacs init file: (defun ctbl:uid () "[internal] Generate an unique number." - (incf ctbl:uid)) + (cl-incf ctbl:uid)) (defun ctbl:fill-keymap-property (begin end keymap) "[internal] Put the given text property to the region between BEGIN and END. If the text already has some keymap property, the text is skipped." (save-excursion (goto-char begin) - (loop with pos = begin with nxt = nil + (cl-loop with pos = begin with nxt = nil until (or (null pos) (<= end pos)) when (get-text-property pos 'keymap) do (setq pos (next-single-property-change pos 'keymap)) @@ -265,7 +267,7 @@ If data is an instance of `ctbl:async-model', this function do nothing." ;; Component -(defstruct ctbl:component +(cl-defstruct ctbl:component "Component This structure defines attributes of the table component. @@ -288,7 +290,7 @@ states : alist of arbitrary data for internal use" ;; Rendering Destination -(defstruct ctbl:dest +(cl-defstruct ctbl:dest "Rendering Destination This structure object is the abstraction of the rendering @@ -352,7 +354,7 @@ calculated from the window that shows BUF or the selected window. The component object is stored at the buffer local variable `ctbl:component'. CUSTOM-MAP is the additional keymap that is added to default keymap `ctbl:table-mode-map'." - (lexical-let + (let ((buffer (or buf (get-buffer-create (format "*Table: %d*" (ctbl:uid))))) (window (or (and buf (get-buffer-window buf)) (selected-window))) dest) @@ -382,7 +384,7 @@ space. This destination is employed to be embedded in the some application buffer. Because this destination does not set up any modes and key maps for the buffer, the application that uses the ctable is responsible to manage the buffer and key maps." - (lexical-let + (let ((mark-begin mark-begin) (mark-end mark-end) (window (or (get-buffer-window buf) (selected-window)))) (make-ctbl:dest @@ -409,7 +411,7 @@ the ctable is responsible to manage the buffer and key maps." (defun ctbl:dest-init-inline (width height) "Create a text destination." - (lexical-let + (let ((buffer (get-buffer-create ctbl:dest-background-buffer)) (window (selected-window)) dest) @@ -430,7 +432,7 @@ the ctable is responsible to manage the buffer and key maps." (defun ctbl:dest-ol-selection-clear (dest) "[internal] Clear the selection overlays on the current table view." - (loop for i in (ctbl:dest-select-ol dest) + (cl-loop for i in (ctbl:dest-select-ol dest) do (delete-overlay i)) (setf (ctbl:dest-select-ol dest) nil)) @@ -438,7 +440,7 @@ the ctable is responsible to manage the buffer and key maps." "[internal] Put a selection overlay on CELL-ID. The selection overlay can be put on some cells, calling this function many times. This function does not manage the selections, just put the overlay." - (lexical-let (ols (row-id (car cell-id)) (col-id (cdr cell-id))) + (let (ols (row-id (car cell-id)) (col-id (cdr cell-id))) (ctbl:dest-with-region dest (ctbl:find-all-by-row-id dest row-id @@ -583,7 +585,7 @@ HOOK is a function that has no argument." ;; asynchronous model ((ctbl:async-model-p (ctbl:model-data (ctbl:component-model component))) - (lexical-let ((cp component)) + (let ((cp component)) (ctbl:async-state-on-update cp) (ctbl:render-async-main dest @@ -622,21 +624,21 @@ HOOK is a function that has no argument." (defun ctbl:cp-fire-click-hooks (component) "[internal] Call click hook functions of the component with no arguments." - (loop for f in (ctbl:component-click-hooks component) + (cl-loop for f in (ctbl:component-click-hooks component) do (condition-case err (funcall f) (error (message "CTable: Click / Hook error %S [%s]" f err))))) (defun ctbl:cp-fire-selection-change-hooks (component) "[internal] Call selection change hook functions of the component with no arguments." - (loop for f in (ctbl:component-selection-change-hooks component) + (cl-loop for f in (ctbl:component-selection-change-hooks component) do (condition-case err (funcall f) (error (message "CTable: Selection change / Hook error %S [%s]" f err))))) (defun ctbl:cp-fire-update-hooks (component) "[internal] Call update hook functions of the component with no arguments." - (loop for f in (ctbl:component-update-hooks component) + (cl-loop for f in (ctbl:component-update-hooks component) do (condition-case err (funcall f) (error (message "Ctable: Update / Hook error %S [%s]" f err))))) @@ -649,18 +651,18 @@ HOOK is a function that has no argument." (max (ctbl:dest-point-max dest)) (mid (/ (+ min max) 2))) (save-excursion - (loop for next = (next-single-property-change mid 'ctbl:cell-id nil max) + (cl-loop for next = (next-single-property-change mid 'ctbl:cell-id nil max) for cur-row-id = (and next (car (ctbl:cursor-to-cell next))) do (cond - ((>= next max) (return (point))) + ((>= next max) (cl-return (point))) ((null cur-row-id) (setq mid next)) ((= cur-row-id row-id) (goto-char mid) (beginning-of-line) - (return (point))) + (cl-return (point))) ((and (< row-id-lim cur-row-id) (< cur-row-id row-id)) (goto-char mid) (beginning-of-line) (forward-line) - (return (point))) + (cl-return (point))) ((< cur-row-id row-id) (setq min mid) (setq mid (/ (+ min max) 2))) @@ -672,13 +674,13 @@ HOOK is a function that has no argument." "[internal] Return a point where the text property `ctbl:cell-id' is equal to cell-id in the current table view. If CELL-ID is not found in the current view, return nil." - (loop with pos = (ctbl:find-position-fast dest cell-id) + (cl-loop with pos = (ctbl:find-position-fast dest cell-id) with end = (ctbl:dest-point-max dest) for next = (next-single-property-change pos 'ctbl:cell-id nil end) for text-cell = (and next (ctbl:cursor-to-cell next)) while (and next (< next end)) do (if (and text-cell (equal cell-id text-cell)) - (return next)) + (cl-return next)) (setq pos next))) (defun ctbl:find-all-by-cell-id (dest cell-id func) @@ -686,7 +688,7 @@ found in the current view, return nil." text-property `ctbl:cell-id' is equal to CELL-ID. The argument function FUNC receives two arguments, begin position and end one. This function is mainly used at functions for putting overlays." - (loop with pos = (ctbl:find-position-fast dest cell-id) + (cl-loop with pos = (ctbl:find-position-fast dest cell-id) with end = (ctbl:dest-point-max dest) for next = (next-single-property-change pos 'ctbl:cell-id nil end) for text-id = (and next (ctbl:cursor-to-cell next)) @@ -694,7 +696,7 @@ mainly used at functions for putting overlays." (if (and text-id (equal cell-id text-id)) (let ((cend (next-single-property-change next 'ctbl:cell-id nil end))) - (return (funcall func next cend)))) + (cl-return (funcall func next cend)))) (setq pos next))) (defun ctbl:find-all-by-row-id (dest row-id func) @@ -703,7 +705,7 @@ row-id of the text-property `ctbl:cell-id' is equal to ROW-ID. The argument function FUNC receives three arguments, cell-id, begin position and end one. This function is mainly used at functions for putting overlays." - (loop with pos = (ctbl:find-position-fast dest (cons row-id nil)) + (cl-loop with pos = (ctbl:find-position-fast dest (cons row-id nil)) with end = (ctbl:dest-point-max dest) for next = (next-single-property-change pos 'ctbl:cell-id nil end) for text-id = (and next (ctbl:cursor-to-cell next)) @@ -715,7 +717,7 @@ at functions for putting overlays." next 'ctbl:cell-id nil end))) (funcall func text-id next cend))) ((< row-id (car text-id)) - (return nil)))) + (cl-return nil)))) (setq pos next))) (defun ctbl:find-first-cell (dest) @@ -752,7 +754,7 @@ bug), this function may return nil." (if (null cmds) (ctbl:cursor-to-cell) (ignore-errors (funcall (car cmds)) (funcall get (cdr cmds))))))) - (or (loop for i in `((,d) (,r) (,u) (,l) + (or (cl-loop for i in `((,d) (,r) (,u) (,l) (,d ,r) (,d ,l) (,u ,r) (,u ,l) (,d ,d) (,r ,r) (,u ,u) (,l ,l)) for id = (funcall get i) @@ -849,7 +851,7 @@ bug), this function may return nil." (ctbl:navi-goto-cell (ctbl:cell-id row-id - (position col-name col-names :test 'equal)))))) + (cl-position col-name col-names :test 'equal)))))) (defun ctbl:action-update-buffer () "Update action for the latest table model." @@ -868,7 +870,7 @@ bug), this function may return nil." (defun ctbl:fire-column-header-action (cp col-id) "[internal] Execute action handlers on the header columns." (when (and cp col-id) - (loop with cmodel = (nth col-id (ctbl:model-column-model (ctbl:cp-get-model cp))) + (cl-loop with cmodel = (nth col-id (ctbl:model-column-model (ctbl:cp-get-model cp))) for f in (ctbl:cmodel-click-hooks cmodel) do (condition-case err (funcall f cp col-id) @@ -877,7 +879,7 @@ bug), this function may return nil." (defun ctbl:render-column-header-keymap (col-id) "[internal] Generate action handler on the header columns. (for header-line-format)" - (lexical-let ((col-id col-id)) + (let ((col-id col-id)) (let ((keymap (copy-keymap ctbl:column-header-keymap))) (define-key keymap [header-line mouse-1] (lambda () @@ -953,8 +955,8 @@ bug), this function may return nil." "[internal] Return a list of rows. This function makes side effects: cell widths are stored at COLUMN-WIDTHS, longer cell strings are truncated by maximum width of the column models." - (loop for row in rows collect - (loop for c in row + (cl-loop for row in rows collect + (cl-loop for c in row for cm in cmodels for cwmax = (ctbl:cmodel-max-width cm) for i from 0 @@ -976,7 +978,7 @@ function expands columns. The residual width is distributed over the columns. If TOTAL-WIDTHS is longer than sum of COLUMN-WIDTHS, this function shrinks columns to reduce the surplus width." - (let ((init-total (loop for i in column-widths sum i))) + (let ((init-total (cl-loop for i in column-widths sum i))) (cond ((or (null total-width) (= total-width init-total)) column-widths) @@ -990,58 +992,58 @@ surplus width." (defun ctbl:render-adjust-cell-width-shrink (cmodels column-widths total-width init-total ) "[internal] shrink column widths." (let* ((column-widths (copy-sequence column-widths)) - (column-indexes (loop for i from 0 below (length cmodels) collect i)) + (column-indexes (cl-loop for i from 0 below (length cmodels) collect i)) (residual (- init-total total-width))) - (loop for cnum = (length column-indexes) + (cl-loop for cnum = (length column-indexes) until (or (= 0 cnum) (= 0 residual)) do - (loop with ave-shrink = (max 1 (/ residual cnum)) + (cl-loop with ave-shrink = (max 1 (/ residual cnum)) for idx in column-indexes for cmodel = (nth idx cmodels) for cwidth = (nth idx column-widths) for min-width = (or (ctbl:cmodel-min-width cmodel) 1) do (cond - ((<= residual 0) (return)) ; complete + ((<= residual 0) (cl-return)) ; complete ((<= cwidth min-width) ; reject (setq column-indexes (delete idx column-indexes))) (t ; reduce (let ((next-width (max 1 (- cwidth ave-shrink)))) - (incf residual (- next-width cwidth)) + (cl-incf residual (- next-width cwidth)) (setf (nth idx column-widths) next-width)))))) column-widths)) (defun ctbl:render-adjust-cell-width-expand (cmodels column-widths total-width init-total ) "[internal] expand column widths." (let* ((column-widths (copy-sequence column-widths)) - (column-indexes (loop for i from 0 below (length cmodels) collect i)) + (column-indexes (cl-loop for i from 0 below (length cmodels) collect i)) (residual (- total-width init-total))) - (loop for cnum = (length column-indexes) + (cl-loop for cnum = (length column-indexes) until (or (= 0 cnum) (= 0 residual)) do - (loop with ave-expand = (max 1 (/ residual cnum)) + (cl-loop with ave-expand = (max 1 (/ residual cnum)) for idx in column-indexes for cmodel = (nth idx cmodels) for cwidth = (nth idx column-widths) for max-width = (or (ctbl:cmodel-max-width cmodel) total-width) do (cond - ((<= residual 0) (return)) ; complete + ((<= residual 0) (cl-return)) ; complete ((<= max-width cwidth) ; reject (setq column-indexes (delete idx column-indexes))) (t ; expand (let ((next-width (min max-width (+ cwidth ave-expand)))) - (incf residual (- cwidth next-width)) + (cl-incf residual (- cwidth next-width)) (setf (nth idx column-widths) next-width)))))) column-widths)) (defun ctbl:render-get-formats (cmodels column-widths) "[internal] Return a list of the format functions." - (loop for cw in column-widths + (cl-loop for cw in column-widths for cm in cmodels for al = (ctbl:cmodel-align cm) collect - (lexical-let ((cw cw)) + (let ((cw cw)) (cond ((eq al 'left) (lambda (s) (ctbl:format-left cw s))) @@ -1140,7 +1142,7 @@ surplus width." (ctbl:render-hline-color (concat (if (ctbl:render-draw-vline-p model vparam 0) left) - (loop with ret = nil with endi = (length column-widths) + (cl-loop with ret = nil with endi = (length column-widths) for cw in column-widths for ci from 1 for endp = (equal ci endi) @@ -1163,7 +1165,7 @@ surplus width." (list (ctbl:render-vline-color V model param 0)) nil)) ;; content line - (loop with param-vl = (ctbl:param-draw-vlines param) + (cl-loop with param-vl = (ctbl:param-draw-vlines param) with param-vc = (ctbl:param-vline-colors param) with endi = (length columns) for i from 1 for endp = (equal i endi) @@ -1187,20 +1189,20 @@ surplus width." (let ((sum 0)) ;; left border line (when (ctbl:render-draw-vline-p model (ctbl:param-draw-vlines param) 0) - (incf sum)) + (cl-incf sum)) ;; content line - (loop with param-vl = (ctbl:param-draw-vlines param) + (cl-loop with param-vl = (ctbl:param-draw-vlines param) with endi = (length cmodels) for i from 1 upto (length cmodels) for endp = (equal i endi) do (when (and (ctbl:render-draw-vline-p model (ctbl:param-draw-vlines param) i) (not endp)) - (incf sum))) + (cl-incf sum))) ;; right border line (when (ctbl:render-draw-vline-p model (ctbl:param-draw-vlines param) -1) - (incf sum)) + (cl-incf sum)) sum)) (defun ctbl:dest-width-get (dest) @@ -1232,7 +1234,7 @@ This function assumes that the current buffer is the destination buffer." (copy-sequence (ctbl:model-data model)) cmodels (ctbl:model-sort-state model))) (column-widths - (loop for c in cmodels + (cl-loop for c in cmodels for title = (ctbl:cmodel-title c) collect (max (or (ctbl:cmodel-min-width c) 0) (or (and title (length title)) 0)))) @@ -1262,7 +1264,7 @@ This function assumes that the current buffer is the destination buffer." (let ((EOL "\n") (header-string (ctbl:render-join-columns - (loop for cm in cmodels + (cl-loop for cm in cmodels for i from 0 for cw in column-widths collect @@ -1296,7 +1298,7 @@ This function assumes that the current buffer is the destination buffer." (unless begin-index (setq begin-index 0)) (let ((EOL "\n") (row-num (length rows))) - (loop for cols in rows + (cl-loop for cols in rows for row-index from begin-index do (insert @@ -1304,7 +1306,7 @@ This function assumes that the current buffer is the destination buffer." column-widths model param (1+ row-index))) (insert (ctbl:render-join-columns - (loop for i in cols + (cl-loop for i in cols for s = (if (stringp i) i (format "%s" i)) for fmt in column-formats for cw in column-widths @@ -1334,7 +1336,7 @@ This function assumes that the current buffer is the destination buffer." ;; async data / internal state -(defstruct ctbl:async-state +(cl-defstruct ctbl:async-state "Rendering State [internal] status : symbol -> @@ -1365,7 +1367,7 @@ panel-end : end mark object for status panel (amodel (ctbl:model-data (ctbl:cp-get-model cp))) (astate (ctbl:cp-states-get cp 'async-state))) (when cp - (case (ctbl:async-state-status astate) + (cl-case (ctbl:async-state-status astate) ('normal (ctbl:render-async-continue cp)) ('requested @@ -1395,7 +1397,7 @@ panel-end : end mark object for status panel (goto-char begin) (insert (propertize - (case (ctbl:async-state-status astate) + (cl-case (ctbl:async-state-status astate) ('done (ctbl:format-center width "No more data.")) ('requested @@ -1428,7 +1430,7 @@ panel-end : end mark object for status panel (defun ctbl:render-async-main (dest model param rows-setter) "[internal] Rendering the table view for async data model. This function assumes that the current buffer is the destination buffer." - (lexical-let* + (let* ((dest dest) (model model) (param param) (rows-setter rows-setter) (amodel (ctbl:model-data model)) (buf (current-buffer)) (cmodels (ctbl:model-column-model model))) @@ -1439,7 +1441,7 @@ This function assumes that the current buffer is the destination buffer." (with-current-buffer buf (let (buffer-read-only drows column-formats (column-widths - (loop for c in cmodels + (cl-loop for c in cmodels for title = (ctbl:cmodel-title c) collect (max (or (ctbl:cmodel-min-width c) 0) (or (and title (length title)) 0)))) @@ -1466,7 +1468,7 @@ This function assumes that the current buffer is the destination buffer." (make-ctbl:async-state :status 'normal :actual-width (+ (ctbl:render-sum-vline-widths cmodels model param) - (loop for i in column-widths sum i)) + (cl-loop for i in column-widths sum i)) :column-widths column-widths :column-formats column-formats :next-index (length rows) :panel-begin mark-panel-begin :panel-end mark-panel-end)) @@ -1478,7 +1480,7 @@ This function assumes that the current buffer is the destination buffer." (defun ctbl:render-async-continue (component) "[internal] Rendering subsequent data asynchronously." - (lexical-let* + (let* ((cp component) (dest (ctbl:component-dest cp)) (buf (current-buffer)) (model (ctbl:cp-get-model cp)) (amodel (ctbl:model-data model)) @@ -1538,7 +1540,7 @@ to urge async data model to request next data chunk." (defun ctbl:async-model-wrapper (rows &optional init-num more-num) "This function wraps a list of row data in an asynchronous data model so as to avoid Emacs freezing with a large number of rows." - (lexical-let ((rows rows) (rest-rows rows) + (let ((rows rows) (rest-rows rows) (init-num (or init-num 100)) (more-num (or more-num 100))) (make-ctbl:async-model @@ -1550,13 +1552,13 @@ model so as to avoid Emacs freezing with a large number of rows." ((null rest-rows) nil) (t (nreverse - (loop with pos = rest-rows + (cl-loop with pos = rest-rows with ret = nil for i from 0 below len do (push (car pos) ret) (setq pos (cdr pos)) - (unless pos (return ret)) + (unless pos (cl-return ret)) finally return ret))))) (when rest-rows (setq rest-rows (nthcdr len rest-rows)))) @@ -1690,7 +1692,7 @@ sides with the character PADDING." (let* ((comparator (lambda (ref) - (lexical-let + (let ((ref ref) (f (or (ctbl:cmodel-sorter (nth ref cmodels)) 'ctbl:sort-string-lessp))) @@ -1698,24 +1700,24 @@ sides with the character PADDING." (funcall f (nth ref i) (nth ref j)))))) (negative-comparator (lambda (ref) - (lexical-let ((cp (funcall comparator ref))) + (let ((cp (funcall comparator ref))) (lambda (i j) (- (funcall cp i j)))))) (to-bool (lambda (f) - (lexical-let ((f f)) + (let ((f f)) (lambda (i j) (< (funcall f i j) 0))))) (chain (lambda (fs) - (lexical-let ((fs fs)) + (let ((fs fs)) (lambda (i j) - (loop for f in fs + (cl-loop for f in fs for v = (funcall f i j) unless (eq 0 v) return v finally return 0)))))) (sort rows - (loop with fs = nil + (cl-loop with fs = nil for o in (reverse (copy-sequence orders)) for gen = (if (< 0 o) comparator negative-comparator) for f = (funcall gen (1- (abs o))) @@ -1737,7 +1739,7 @@ sides with the character PADDING." ;; buffer -(defun* ctbl:open-table-buffer(&key buffer width height custom-map model param) +(cl-defun ctbl:open-table-buffer (&key buffer width height custom-map model param) "Open a table buffer simply. This function uses the function `ctbl:create-table-component-buffer' internally." @@ -1746,7 +1748,7 @@ This function uses the function :custom-map custom-map :model model :param param))) (switch-to-buffer (ctbl:cp-get-buffer cp)))) -(defun* ctbl:create-table-component-buffer(&key buffer width height custom-map model param) +(cl-defun ctbl:create-table-component-buffer (&key buffer width height custom-map model param) "Return a table buffer with some customize parameters. This function binds the component object at the @@ -1797,9 +1799,9 @@ CUSTOM-MAP is the additional keymap that is added to default keymap `ctbl:table- (and (car rows) (length (car rows))))) (column-models (if header-row - (loop for i in header-row + (cl-loop for i in header-row collect (make-ctbl:cmodel :title (format "%s" i) :min-width 5)) - (loop for i from 0 below col-num + (cl-loop for i from 0 below col-num for ch = (char-to-string (+ ?A i)) collect (make-ctbl:cmodel :title ch :min-width 5))))) (make-ctbl:model @@ -1807,7 +1809,7 @@ CUSTOM-MAP is the additional keymap that is added to default keymap `ctbl:table- ;; region -(defun* ctbl:create-table-component-region(&key width height keymap model param) +(cl-defun ctbl:create-table-component-region (&key width height keymap model param) "Insert markers of the rendering destination at current point and display the table view. This function returns a component object and stores it at the text property `ctbl:component'. @@ -1822,7 +1824,7 @@ KEYMAP is the keymap that is put to the text property `keymap'. If KEYMAP is nil (let* ((dest (ctbl:dest-init-region (current-buffer) mark-begin mark-end width height)) (cp (ctbl:cp-new dest model param)) (after-update-func - (lexical-let ((keymap keymap) (cp cp)) + (let ((keymap keymap) (cp cp)) (lambda () (ctbl:dest-with-region (ctbl:component-dest cp) (let (buffer-read-only) @@ -1838,7 +1840,7 @@ KEYMAP is the keymap that is put to the text property `keymap'. If KEYMAP is nil ;; inline -(defun* ctbl:get-table-text(&key width height model param) +(cl-defun ctbl:get-table-text (&key width height model param) "Return a text that is drew the table view. In this case, the rendering destination object is disposable. So, @@ -1913,7 +1915,7 @@ WIDTH and HEIGHT are reference size of the table view." (ctbl:cp-add-update-hook cp (lambda () (message "CTable : Update Hook"))) (switch-to-buffer (ctbl:cp-get-buffer cp))))) -;; (progn (eval-current-buffer) (ctbl:demo)) +;; (progn (eval-buffer) (ctbl:demo)) (provide 'ctable) diff --git a/lisp/ivy/colir.el b/lisp/ivy/colir.el index 9e61273b..09b4f5cf 100644 --- a/lisp/ivy/colir.el +++ b/lisp/ivy/colir.el @@ -1,6 +1,6 @@ ;;; colir.el --- Color blending library -*- lexical-binding: t -*- -;; Copyright (C) 2015-2019 Free Software Foundation, Inc. +;; Copyright (C) 2015-2021 Free Software Foundation, Inc. ;; Author: Oleh Krehel diff --git a/lisp/ivy/ivy-faces.el b/lisp/ivy/ivy-faces.el index 54492c47..bedb9cb1 100644 --- a/lisp/ivy/ivy-faces.el +++ b/lisp/ivy/ivy-faces.el @@ -1,6 +1,6 @@ ;;; ivy-faces.el --- Faces for Ivy -*- lexical-binding: t -*- -;; Copyright (C) 2020 Free Software Foundation, Inc. +;; Copyright (C) 2020-2021 Free Software Foundation, Inc. ;; Author: Oleh Krehel ;; Keywords: convenience diff --git a/lisp/ivy/ivy-overlay.el b/lisp/ivy/ivy-overlay.el index ed77fc02..f5373584 100644 --- a/lisp/ivy/ivy-overlay.el +++ b/lisp/ivy/ivy-overlay.el @@ -1,6 +1,6 @@ ;;; ivy-overlay.el --- Overlay display functions for Ivy -*- lexical-binding: t -*- -;; Copyright (C) 2016-2019 Free Software Foundation, Inc. +;; Copyright (C) 2016-2021 Free Software Foundation, Inc. ;; Author: Oleh Krehel ;; Keywords: convenience diff --git a/lisp/ivy/ivy-pkg.el b/lisp/ivy/ivy-pkg.el index da381d68..e78c567e 100644 --- a/lisp/ivy/ivy-pkg.el +++ b/lisp/ivy/ivy-pkg.el @@ -1,6 +1,6 @@ -(define-package "ivy" "20210105.2002" "Incremental Vertical completYon" +(define-package "ivy" "20211231.1730" "Incremental Vertical completYon" '((emacs "24.5")) - :commit "71c59aecf669142ebe264fac8ff7b440c0c71712" :authors + :commit "c97ea72285f2428ed61b519269274d27f2b695f9" :authors '(("Oleh Krehel" . "ohwoeowho@gmail.com")) :maintainer '("Oleh Krehel" . "ohwoeowho@gmail.com") diff --git a/lisp/ivy/ivy.el b/lisp/ivy/ivy.el index feecf746..a3e9ec7d 100644 --- a/lisp/ivy/ivy.el +++ b/lisp/ivy/ivy.el @@ -1,10 +1,10 @@ ;;; ivy.el --- Incremental Vertical completYon -*- lexical-binding: t -*- -;; Copyright (C) 2015-2020 Free Software Foundation, Inc. +;; Copyright (C) 2015-2021 Free Software Foundation, Inc. ;; Author: Oleh Krehel ;; URL: https://github.com/abo-abo/swiper -;; Version: 0.13.0 +;; Version: 0.13.4 ;; Package-Requires: ((emacs "24.5")) ;; Keywords: matching @@ -99,7 +99,8 @@ a behavior similar to `swiper'." The usual reason for `ivy-backward-delete-char' to fail is when there is no text left to delete, i.e., when it is called at the beginning of the minibuffer. -The default setting provides a quick exit from completion." +The default setting provides a quick exit from completion. +Another common option is `ignore', which does nothing." :type '(choice (const :tag "Exit completion" abort-recursive-edit) (const :tag "Do nothing" ignore) @@ -695,29 +696,33 @@ candidate, not the prompt." (if (ivy--prompt-selected-p) (ivy-immediate-done) (setq ivy-current-prefix-arg current-prefix-arg) - (delete-minibuffer-contents) - (cond ((and (= ivy--length 0) - (eq this-command 'ivy-dispatching-done)) - (ivy--done ivy-text)) - ((or (> ivy--length 0) - ;; the action from `ivy-dispatching-done' may not need a - ;; candidate at all - (eq this-command 'ivy-dispatching-done)) - (ivy--done (ivy-state-current ivy-last))) - ((and (memq (ivy-state-collection ivy-last) - '(read-file-name-internal internal-complete-buffer)) - (eq confirm-nonexistent-file-or-buffer t) - (not (string= " (confirm)" ivy--prompt-extra))) - (setq ivy--prompt-extra " (confirm)") - (insert ivy-text) - (ivy--exhibit)) - ((memq (ivy-state-require-match ivy-last) - '(nil confirm confirm-after-completion)) - (ivy--done ivy-text)) - (t - (setq ivy--prompt-extra " (match required)") - (insert ivy-text) - (ivy--exhibit))))) + (let ((require-match (ivy-state-require-match ivy-last)) + (input (ivy--input))) + (delete-minibuffer-contents) + (cond ((and (= ivy--length 0) + (eq this-command 'ivy-dispatching-done)) + (ivy--done ivy-text)) + ((or (> ivy--length 0) + ;; the action from `ivy-dispatching-done' may not need a + ;; candidate at all + (eq this-command 'ivy-dispatching-done)) + (ivy--done (ivy-state-current ivy-last))) + ((string= " (confirm)" ivy--prompt-extra) + (ivy--done ivy-text)) + ((or (and (memq (ivy-state-collection ivy-last) + '(read-file-name-internal internal-complete-buffer)) + (eq confirm-nonexistent-file-or-buffer t)) + (and (functionp require-match) + (setq require-match (funcall require-match)))) + (setq ivy--prompt-extra " (confirm)") + (insert input) + (ivy--exhibit)) + ((memq require-match '(nil confirm confirm-after-completion)) + (ivy--done ivy-text)) + (t + (setq ivy--prompt-extra " (match required)") + (insert ivy-text) + (ivy--exhibit)))))) (defvar ivy-mouse-1-tooltip "Exit the minibuffer with the selected candidate." @@ -783,10 +788,11 @@ key (a string), cmd and doc (a string)." "\n"))) (defun ivy-read-action-format-columns (actions) - "Create a docstring from ACTIONS, using several columns if needed to preserve `ivy-height'. + "Create a potentially multi-column docstring from ACTIONS. +Several columns are used as needed to preserve `ivy-height'. -ACTIONS is a list. Each list item is a list of 3 items: key (a -string), cmd and doc (a string)." +ACTIONS is a list with elements of the form (KEY COMMAND DOC), +where KEY and DOC are strings." (let ((length (length actions)) (i 0) (max-rows (- ivy-height 1)) @@ -854,7 +860,8 @@ selection, non-nil otherwise." (cdr actions))) (not (string= key (car (nth action-idx (cdr actions)))))) (setq key (concat key (key-description (vector (read-key hint)))))) - (ivy-shrink-after-dispatching) + ;; Ignore resize errors with minibuffer-only frames (#2726). + (ignore-errors (ivy-shrink-after-dispatching)) (cond ((member key '("ESC" "C-g" "M-o")) nil) ((null action-idx) @@ -932,10 +939,10 @@ Is is a cons cell, related to `tramp-get-completion-function'." :type '(alist :key-type symbol :value-type function)) (defun ivy--completing-fname-p () - (eq 'file (cdr (assoc - 'category - (ignore-errors - (funcall (ivy-state-collection ivy-last) ivy-text nil 'metadata)))))) + (let ((meta (ignore-errors + (funcall (ivy-state-collection ivy-last) ivy-text nil 'metadata)))) + (and (consp meta) + (eq 'file (cdr (assoc 'category meta)))))) (defun ivy-alt-done (&optional arg) "Exit the minibuffer with the selected candidate. @@ -1117,34 +1124,45 @@ If the text hasn't changed as a result, forward to `ivy-alt-done'." (defun ivy-partial () "Complete the minibuffer text as much as possible." (interactive) - (let* ((parts (or (ivy--split-spaces ivy-text) (list ""))) - (tail (last parts)) - (postfix (car tail)) - (case-fold-search (ivy--case-fold-p ivy-text)) - (completion-ignore-case case-fold-search) - (new (try-completion (string-remove-prefix "^" postfix) - (if (ivy-state-dynamic-collection ivy-last) - ivy--all-candidates + (if (ivy-state-dynamic-collection ivy-last) + (let* ((bnd + (ignore-errors + (funcall + (ivy-state-collection ivy-last) + ivy-text nil (cons 'boundaries (buffer-substring (point) (line-end-position)))))) + (beg (+ (minibuffer-prompt-end) + (if bnd (cadr bnd) 0)))) + (delete-region beg (point-max)) + (insert + (ivy-state-current ivy-last)) + t) + (let* ((parts (or (ivy--split-spaces ivy-text) (list ""))) + (tail (last parts)) + (postfix (car tail)) + (case-fold-search (ivy--case-fold-p ivy-text)) + (completion-ignore-case case-fold-search) + (new (try-completion (string-remove-prefix "^" postfix) (mapcar (lambda (str) (let ((i (string-match-p postfix str))) (and i (substring str i)))) - ivy--old-cands))))) - (cond ((eq new t) nil) - ((string= new ivy-text) nil) - ((string= (car tail) (car (ivy--split-spaces new))) nil) - (new - (delete-region (minibuffer-prompt-end) (point-max)) - (setcar tail - (if (= (string-to-char postfix) ?^) - (concat "^" new) - new)) - (ivy-set-text - (concat - (mapconcat #'identity parts " ") - (and ivy-tab-space (not (= (length ivy--old-cands) 1)) " "))) - (insert ivy-text) - (ivy--partial-cd-for-single-directory) - t)))) + ivy--old-cands)))) + (cond + ((eq new t) nil) + ((string= new ivy-text) nil) + ((string= (car tail) (car (ivy--split-spaces new))) nil) + (new + (delete-region (minibuffer-prompt-end) (point-max)) + (setcar tail + (if (= (string-to-char postfix) ?^) + (concat "^" new) + new)) + (ivy-set-text + (concat + (mapconcat #'identity parts " ") + (and ivy-tab-space (not (= (length ivy--old-cands) 1)) " "))) + (insert ivy-text) + (ivy--partial-cd-for-single-directory) + t))))) (defvar ivy-completion-beg nil "Completion bounds start.") @@ -1658,7 +1676,9 @@ minibuffer." "Forward to `kill-line'." (interactive) (if (eolp) - (kill-region (minibuffer-prompt-end) (point)) + (progn + (kill-region (minibuffer-prompt-end) (point)) + (setq ivy--old-text (current-kill 0 t))) (kill-line))) (defun ivy-kill-whole-line () @@ -1703,6 +1723,8 @@ This string is inserted into the minibuffer." (const :tag "Default" ivy-format-function-default) (const :tag "Arrow prefix" ivy-format-function-arrow) (const :tag "Full line" ivy-format-function-line) + (const :tag "Arrow prefix + full line" + ivy-format-function-arrow-line) (function :tag "Custom function")))) (defun ivy-sort-file-function-default (x y) @@ -1769,7 +1791,8 @@ specified for the current collection in `ivy-sort-functions-alist'." (interactive) (let ((cell (or (assq (ivy-state-collection ivy-last) ivy-sort-functions-alist) - (assq (ivy-state-caller ivy-last) ivy-sort-functions-alist)))) + (assq (ivy-state-caller ivy-last) ivy-sort-functions-alist) + (assq t ivy-sort-functions-alist)))) (when (consp (cdr cell)) (setcdr cell (nconc (cddr cell) (list (cadr cell)))) (ivy--reset-state ivy-last)))) @@ -1892,6 +1915,7 @@ The child caller inherits and can override the settings of the parent.") unwind-fn index-fn sort-fn + sort-matches-fn format-fn display-fn display-transformer-fn @@ -1919,6 +1943,8 @@ The child caller inherits and can override the settings of the parent.") (ivy--alist-set 'ivy-index-functions-alist caller index-fn)) (when sort-fn (ivy--alist-set 'ivy-sort-functions-alist caller sort-fn)) + (when sort-matches-fn + (ivy--alist-set 'ivy-sort-matches-functions-alist caller sort-matches-fn)) (when format-fn (ivy--alist-set 'ivy-format-functions-alist caller format-fn)) (when display-fn @@ -2032,7 +2058,7 @@ PREDICATE is applied to filter out the COLLECTION immediately. This argument is for compatibility with `completing-read'. When REQUIRE-MATCH is non-nil, only members of COLLECTION can be -selected. +selected. In can also be a lambda. If INITIAL-INPUT is non-nil, then insert that input in the minibuffer initially. @@ -2212,10 +2238,21 @@ customizations apply to the current completion session." (defvar Info-complete-menu-buffer) +(defun ivy--alist-to-cands (alist) + "Transform ALIST to a list of strings." + (let ((i -1)) + (mapcar (lambda (x) + (propertize x 'idx (cl-incf i))) + (all-completions "" alist)))) + +(defvar ivy--minibuffer-metadata nil + "Store `completion-metadata'.") + (defun ivy--reset-state (state) "Reset the ivy to STATE. This is useful for recursive `ivy-read'." (setq ivy-marked-candidates nil) + (setq ivy--minibuffer-metadata nil) (unless (equal (selected-frame) (ivy-state-frame state)) (select-window (active-minibuffer-window))) (let* ((prompt (or (ivy-state-prompt state) "")) @@ -2324,6 +2361,12 @@ This is useful for recursive `ivy-read'." counsel-switch-buffer))) predicate))) (dynamic-collection + (setq ivy--minibuffer-metadata + (ignore-errors + (completion-metadata + "" + (ivy-state-collection ivy-last) + (ivy-state-predicate ivy-last)))) (setq coll (if (and (eq this-command 'ivy-resume) (not (buffer-modified-p))) ivy--all-candidates (ivy--dynamic-collection-cands (or initial-input ""))))) @@ -2333,10 +2376,7 @@ This is useful for recursive `ivy-read'." (setq collection (sort (copy-sequence collection) sort-fn)) (setq sort nil)) (setf (ivy-state-collection ivy-last) collection) - (setq coll (let ((i -1)) - (mapcar (lambda (x) - (propertize x 'idx (cl-incf i))) - (all-completions "" collection))))) + (setq coll (ivy--alist-to-cands collection))) ((or (functionp collection) (byte-code-function-p collection) (vectorp collection) @@ -2503,6 +2543,12 @@ behavior." (declare-function mc/all-fake-cursors "ext:multiple-cursors-core") +;; Kludge: Try to retain original minibuffer completion data. +(defvar ivy--minibuffer-table) +(defvar ivy--minibuffer-pred) +(defvar ivy--minibuffer-try nil + "Store original `try-completion' result for sole completions.") + (defun ivy-completion-in-region-action (str) "Insert STR, erasing the previous one. The previous string is between `ivy-completion-beg' and `ivy-completion-end'." @@ -2518,7 +2564,15 @@ The previous string is between `ivy-completion-beg' and `ivy-completion-end'." (delete-region beg end)) (setq ivy-completion-beg (point)) (insert (substring-no-properties str)) - (completion--done str 'exact) + (let ((minibuffer-completion-table (if (boundp 'ivy--minibuffer-table) + ivy--minibuffer-table + (ivy-state-collection ivy-last))) + (minibuffer-completion-predicate (if (boundp 'ivy--minibuffer-pred) + ivy--minibuffer-pred + (ivy-state-predicate ivy-last)))) + (completion--done str (cond ((eq ivy--minibuffer-try t) 'finished) + ((eq ivy-exit 'done) 'unknown) + ('exact)))) (setq ivy-completion-end (point)) (save-excursion (dolist (cursor fake-cursors) @@ -2558,8 +2612,12 @@ See `completion-in-region' for further information." (let* ((enable-recursive-minibuffers t) (str (buffer-substring-no-properties start end)) (completion-ignore-case (ivy--case-fold-p str)) - (comps - (completion-all-completions str collection predicate (- end start)))) + (md (completion-metadata str collection predicate)) + (reg (- end start)) + (comps (completion-all-completions str collection predicate reg md)) + (try (completion-try-completion str collection predicate reg md)) + (ivy--minibuffer-table collection) + (ivy--minibuffer-pred predicate)) (cond ((null comps) (message "No matches")) ((progn @@ -2586,8 +2644,9 @@ See `completion-in-region' for further information." (progn (unless (minibuffer-window-active-p (selected-window)) (setf (ivy-state-window ivy-last) (selected-window))) - (ivy-completion-in-region-action - (substring-no-properties (car comps)))) + (let ((ivy--minibuffer-try try)) + (ivy-completion-in-region-action + (substring-no-properties (car comps))))) (dolist (s comps) ;; Remove face `completions-first-difference'. (ivy--remove-props s 'face)) @@ -2958,8 +3017,11 @@ tries to ensure that it does not change depending on the number of candidates." (defun ivy--minibuffer-setup () "Setup ivy completion in the minibuffer." - (setq-local mwheel-scroll-up-function 'ivy-next-line) - (setq-local mwheel-scroll-down-function 'ivy-previous-line) + ;; Guard for --without-x builds where `mwheel' is not preloaded. + (when (boundp 'mwheel-scroll-up-function) + (setq-local mwheel-scroll-up-function 'ivy-next-line)) + (when (boundp 'mwheel-scroll-down-function) + (setq-local mwheel-scroll-down-function 'ivy-previous-line)) (setq-local completion-show-inline-help nil) (setq-local line-spacing nil) (setq-local minibuffer-default-add-function @@ -3040,6 +3102,26 @@ parts beyond their respective faces `ivy-confirm-face' and (funcall fn (ivy-state-prompt ivy-last)))) ivy--prompt))) +(defun ivy--break-lines (str width) + "Break each line in STR with newlines to fit into WIDTH columns." + (if (<= width 0) + str + (let (lines) + (dolist (line (split-string str "\n")) + (while (and line (> (string-width line) width)) + (let ((prefix "") (extra 0)) + (while (string-empty-p prefix) + ;; Grow `width' until it fits at least one char from `line'. + (setq prefix (truncate-string-to-width line (+ width extra))) + (setq extra (1+ extra))) + ;; Avoid introducing spurious newline if `prefix' and `line' are + ;; equal, i.e., if `line' couldn't be truncated to `width'. + (setq line (and (> (length line) (length prefix)) + (substring line (length prefix)))) + (push prefix lines))) + (when line (push line lines))) + (string-join (nreverse lines) "\n")))) + (defun ivy--insert-prompt () "Update the prompt according to `ivy--prompt'." (when (setq ivy--prompt (ivy-prompt)) @@ -3080,13 +3162,13 @@ parts beyond their respective faces `ivy-confirm-face' and (save-excursion (goto-char (point-min)) (delete-region (point-min) (minibuffer-prompt-end)) - (let ((len-n (length n-str)) - (len-d (length d-str)) + (let ((wid-n (string-width n-str)) + (wid-d (string-width d-str)) (ww (window-width))) (setq n-str - (cond ((> (+ len-n len-d) ww) + (cond ((> (+ wid-n wid-d) ww) (concat n-str "\n" d-str "\n")) - ((> (+ len-n len-d (length ivy-text)) ww) + ((> (+ wid-n wid-d (string-width ivy-text)) ww) (concat n-str d-str "\n")) (t (concat n-str d-str))))) @@ -3094,11 +3176,7 @@ parts beyond their respective faces `ivy-confirm-face' and (setq n-str (concat (funcall ivy-pre-prompt-function) n-str))) (when ivy-add-newline-after-prompt (setq n-str (concat n-str "\n"))) - (let ((regex (format "\\([^\n]\\{%d\\}\\)[^\n]" (window-width)))) - (while (string-match regex n-str) - (setq n-str (replace-match - (concat (match-string 1 n-str) "\n") - nil t n-str 1)))) + (setq n-str (ivy--break-lines n-str (window-width))) (set-text-properties 0 (length n-str) `(face minibuffer-prompt ,@std-props) n-str) @@ -3284,14 +3362,10 @@ The function was added in Emacs 26.1.") "~" home))))) -(defvar ivy--minibuffer-metadata nil) - (defun ivy-update-candidates (cands) - (let ((ivy--minibuffer-metadata - (completion-metadata "" minibuffer-completion-table minibuffer-completion-predicate))) - (ivy--insert-minibuffer - (ivy--format - (setq ivy--all-candidates cands))))) + (ivy--insert-minibuffer + (ivy--format + (setq ivy--all-candidates cands)))) (defun ivy--exhibit () "Insert Ivy completions display. @@ -3306,7 +3380,10 @@ Should be run via minibuffer `post-command-hook'." t)) (defun ivy--dynamic-collection-cands (input) - (let ((coll (funcall (ivy-state-collection ivy-last) input))) + (let ((coll (condition-case nil + (funcall (ivy-state-collection ivy-last) input) + (error + (funcall (ivy-state-collection ivy-last) input nil nil))))) (if (listp coll) (mapcar (lambda (x) (if (consp x) (car x) x)) coll) coll))) @@ -3922,7 +3999,8 @@ and SEPARATOR is used to join them." separator))) (defun ivy-format-function-default (cands) - "Transform CANDS into a string for minibuffer." + "Transform CANDS into a multiline string for the minibuffer. +Add the face `ivy-current-match' to the selected candidate." (ivy--format-function-generic (lambda (str) (ivy--add-face str 'ivy-current-match)) @@ -3931,7 +4009,9 @@ and SEPARATOR is used to join them." "\n")) (defun ivy-format-function-arrow (cands) - "Transform CANDS into a string for minibuffer." + "Transform CANDS into a multiline string for the minibuffer. +Like `ivy-format-function-default', but also prefix the selected +candidate with an arrow \">\"." (ivy--format-function-generic (lambda (str) (concat "> " (ivy--add-face str 'ivy-current-match))) @@ -3941,9 +4021,13 @@ and SEPARATOR is used to join them." "\n")) (defun ivy-format-function-line (cands) - "Transform CANDS into a string for minibuffer. -Note that since Emacs 27, `ivy-current-match' needs to have :extend t attribute. -It has it by default, but the current theme also needs to set it." + "Transform CANDS into a multiline string for the minibuffer. +Like `ivy-format-function-default', but extend highlighting of +the selected candidate to the window edge. + +Note that since Emacs 27, `ivy-current-match' needs to have a +non-nil :extend attribute. This is the case by default, but it +also needs to be preserved by the current theme." (ivy--format-function-generic (lambda (str) (ivy--add-face (concat str "\n") 'ivy-current-match)) @@ -3952,6 +4036,18 @@ It has it by default, but the current theme also needs to set it." cands "")) +(defun ivy-format-function-arrow-line (cands) + "Transform CANDS into a multiline string for the minibuffer. +This combines the \">\" prefix of `ivy-format-function-arrow' +with the extended highlighting of `ivy-format-function-line'." + (ivy--format-function-generic + (lambda (str) + (concat "> " (ivy--add-face (concat str "\n") 'ivy-current-match))) + (lambda (str) + (concat " " str "\n")) + cands + "")) + (defun ivy--highlight-ignore-order (str) "Highlight STR, using the ignore-order method." (when (consp ivy--old-re) @@ -3984,12 +4080,10 @@ in this case." (defun ivy--highlight-default (str) "Highlight STR, using the default method." - (unless ivy--old-re - (setq ivy--old-re ivy-regex)) (let ((regexps - (if (listp ivy--old-re) - (mapcar #'car (cl-remove-if-not #'cdr ivy--old-re)) - (list ivy--old-re))) + (if (listp ivy-regex) + (mapcar #'car (cl-remove-if-not #'cdr ivy-regex)) + (list ivy-regex))) start) (dolist (re regexps) (ignore-errors @@ -4020,7 +4114,7 @@ in this case." (cl-incf i))))))) str) -(defun ivy--format-minibuffer-line (str) +(defun ivy--format-minibuffer-line (str annot) "Format line STR for use in minibuffer." (let* ((str (ivy-cleanup-string (copy-sequence str))) (str (if (eq ivy-display-style 'fancy) @@ -4033,9 +4127,7 @@ in this case." (concat file (funcall ivy--highlight-function match))) (funcall ivy--highlight-function str)) str)) - (olen (length str)) - (annot (or (completion-metadata-get ivy--minibuffer-metadata 'annotation-function) - (plist-get completion-extra-properties :annotation-function)))) + (olen (length str))) (add-text-properties 0 olen '(mouse-face @@ -4050,7 +4142,7 @@ in this case." (when annot (setq str (concat str (funcall annot str))) (add-face-text-property - olen (length str) 'ivy-completions-annotations nil str)) + olen (length str) 'ivy-completions-annotations t str)) str)) (defun ivy-read-file-transformer (str) @@ -4082,7 +4174,7 @@ CANDS is a list of candidates that :display-transformer can turn into strings." (let* ((bnd (ivy--minibuffer-index-bounds ivy--index ivy--length ivy-height)) (wnd-cands (cl-subseq cands (car bnd) (cadr bnd))) - (case-fold-search (ivy--case-fold-p ivy-text)) + (case-fold-search (ivy--case-fold-p (ivy-re-to-str ivy-regex))) transformer-fn) (setq ivy--window-index (nth 2 bnd)) (when (setq transformer-fn (ivy-state-display-transformer-fn ivy-last)) @@ -4092,13 +4184,18 @@ CANDS is a list of candidates that :display-transformer can turn into strings." (ivy--wnd-cands-to-str wnd-cands)))) (defun ivy--wnd-cands-to-str (wnd-cands) - (let ((str (concat "\n" - (funcall (ivy-alist-setting ivy-format-functions-alist) - (condition-case nil - (mapcar - #'ivy--format-minibuffer-line - wnd-cands) - (error wnd-cands)))))) + (let* ((metadata (unless (ivy-state-dynamic-collection ivy-last) + (completion-metadata "" minibuffer-completion-table + minibuffer-completion-predicate))) + (annot (or (completion-metadata-get metadata 'annotation-function) + (plist-get completion-extra-properties :annotation-function))) + (str (concat "\n" + (funcall (ivy-alist-setting ivy-format-functions-alist) + (condition-case nil + (mapcar + (lambda (cand) (ivy--format-minibuffer-line cand annot)) + wnd-cands) + (error wnd-cands)))))) (put-text-property 0 (length str) 'read-only nil str) str)) @@ -4428,7 +4525,8 @@ BUFFER may be a string or nil." (defun ivy--kill-current-candidate-buffer () (setf (ivy-state-preselect ivy-last) ivy--index) (setq ivy--old-re nil) - (setq ivy--all-candidates (ivy--buffer-list "" ivy-use-virtual-buffers nil)) + (setq ivy--all-candidates (ivy--buffer-list "" ivy-use-virtual-buffers + (ivy-state-predicate ivy-last))) (let ((ivy--recompute-index-inhibit t)) (ivy--exhibit))) @@ -4833,9 +4931,16 @@ You can also delete an element from history with \\[ivy-reverse-i-search-kill]." (delete-minibuffer-contents) (if (ivy-state-dynamic-collection ivy-last) (progn - (setf (ivy-state-dynamic-collection ivy-last) nil) - (setf (ivy-state-collection ivy-last) - (setq ivy--all-candidates ivy--old-cands))) + ;; By disabling `ivy-state-dynamic-collection', we lose the ability + ;; to clearly differentiate between ternary programmed completion + ;; functions and Ivy's unary dynamic collections (short of using + ;; `func-arity' or otherwise redesigning things). So we must also + ;; update the dynamic binding of `minibuffer-completion-table' to no + ;; longer hold a dynamic collection. + (setq minibuffer-completion-table ivy--old-cands) + (setq ivy--all-candidates ivy--old-cands) + (setf (ivy-state-collection ivy-last) ivy--old-cands) + (setf (ivy-state-dynamic-collection ivy-last) nil)) (setq ivy--all-candidates (ivy--filter ivy-text ivy--all-candidates)))) @@ -5029,7 +5134,10 @@ There is no limit on the number of *ivy-occur* buffers." "") ivy-text)))) (with-current-buffer buffer - (funcall occur-fn ivy--old-cands) + (funcall occur-fn + (if (ivy-state-dynamic-collection ivy-last) + (funcall (ivy-state-collection ivy-last) ivy-text) + ivy--old-cands)) (setf (ivy-state-text ivy-last) ivy-text) (setq ivy-occur-last ivy-last)) (ivy-exit-with-action @@ -5051,10 +5159,15 @@ updated original buffer." (let ((caller (ivy-state-caller ivy-occur-last)) (ivy-last ivy-occur-last)) (let ((inhibit-read-only t) - (line (line-number-at-pos))) + (line (line-number-at-pos)) + (text (ivy-state-text ivy-last))) (erase-buffer) + (ivy-set-text text) (funcall (or (plist-get ivy--occurs-list caller) - #'ivy--occur-default) nil) + #'ivy--occur-default) + (and (ivy-state-dynamic-collection ivy-last) + (funcall (ivy-state-collection ivy-last) + text))) (goto-char (point-min)) (forward-line (1- line))) (setq ivy-occur-last ivy-last))) @@ -5187,11 +5300,16 @@ EVENT gives the mouse position." (delete cand ivy-marked-candidates))) (defun ivy--mark (cand) - (let ((marked-cand (concat ivy-mark-prefix cand))) + (let ((marked-cand (copy-sequence (concat ivy-mark-prefix cand)))) + ;; Primarily for preserving `idx'. FIXME: the mark + ;; prefix shouldn't become part of the candidate! + (add-text-properties 0 (length ivy-mark-prefix) + (text-properties-at 0 cand) + marked-cand) (setcar (member cand ivy--all-candidates) (setcar (member cand ivy--old-cands) marked-cand)) (setq ivy-marked-candidates - (append ivy-marked-candidates (list marked-cand))))) + (nconc ivy-marked-candidates (list marked-cand))))) (defun ivy-mark () "Mark the selected candidate and move to the next one. diff --git a/lisp/ivy/ivy.info b/lisp/ivy/ivy.info index 1a78d47b..4b1f2521 100644 --- a/lisp/ivy/ivy.info +++ b/lisp/ivy/ivy.info @@ -1,6 +1,6 @@ -This is ivy.info, produced by makeinfo version 6.5 from ivy.texi. +This is ivy.info, produced by makeinfo version 6.7 from ivy.texi. -Ivy manual, version 0.13.0 +Ivy manual, version 0.13.4 Ivy is an interactive interface for completion in Emacs. Emacs uses completion mechanism in a variety of contexts: code, menus, commands, @@ -11,7 +11,7 @@ available choices while previewing in the minibuffer. Selecting the final candidate is either through simple keyboard character inputs or through powerful regular expressions. - Copyright (C) 2015-2019 Free Software Foundation, Inc. + Copyright (C) 2015–2021 Free Software Foundation, Inc. Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, @@ -19,6 +19,7 @@ through powerful regular expressions. Foundation; with no Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts. A copy of the license is included in the section entitled "GNU Free Documentation License". + INFO-DIR-SECTION Emacs START-INFO-DIR-ENTRY * Ivy: (ivy). Using Ivy for completion. @@ -203,21 +204,22 @@ File: ivy.info, Node: Installing from Emacs Package Manager, Next: Installing ‘M-x’ ‘package-install’ ‘RET’ ‘counsel’ ‘RET’ - Ivy is installed as part of the ‘counsel’ package, which is available -from two different package archives, GNU ELPA and MELPA. For the latest -stable version, use the GNU ELPA archives. For current hourly builds, -use the MELPA archives. + Ivy is installed alongside the ‘counsel’ package, which is available +from two different package archives, GNU ELPA and MELPA. For the latest +stable version, use the GNU ELPA archive. For the latest development +snaphshot, use the GNU-devel ELPA archive. Ivy is split into three packages: ‘ivy’, ‘swiper’ and ‘counsel’; by installing ‘counsel’, the other two are brought in as dependencies. If you are not interested in the extra functionality provided by ‘swiper’ and ‘counsel’, you can install only ‘ivy’. - See the code below for adding MELPA to the list of package archives: + See the code below for adding GNU-devel ELPA to your list of package +archives: (require 'package) (add-to-list 'package-archives - '("melpa" . "https://melpa.org/packages/")) + '("gnu-devel" . "https://elpa.gnu.org/devel/")) After this do ‘M-x’ ‘package-refresh-contents’ ‘RET’, followed by ‘M-x’ ‘package-install’ ‘RET’ ‘counsel’ ‘RET’. @@ -233,7 +235,7 @@ File: ivy.info, Node: Installing from the Git repository, Prev: Installing fro Why install from Git? ..................... - • No need to wait for MELPA’s hourly builds + • No need to wait for GNU ELPA / MELPA builds • Easy to revert to previous versions • Contribute to Ivy’s development; send patches; pull requests @@ -457,11 +459,11 @@ extends usability of lists in Emacs. (should (equal (ivy-with - '(progn - (ivy-read "Test: " '("can do" "can't, sorry" "other")) - ivy-text) - "c ") - "can")) + '(progn + (ivy-read "Test: " '("can do" "can't, sorry" "other")) + ivy-text) + "c ") + "can")) ‘C-M-j’ (‘ivy-immediate-done’) .............................. @@ -494,6 +496,9 @@ keeps the minibuffer open for applying subsequent actions. Adding an extra meta key to the normal key chord invokes the special version of the regular commands that enables applying multiple actions. + Note that these operations are supported only by completion sessions +that use the ‘ivy-read’ API, rather than the built-in ‘completing-read’. + ‘C-M-m’ (‘ivy-call’) .................... @@ -560,7 +565,7 @@ File: ivy.info, Node: Key bindings that alter the minibuffer input, Next: Othe ‘M-p’ (‘ivy-previous-history-element’) ...................................... - Cycles forward through the Ivy command history. + Cycles backwards through the Ivy command history. ‘M-i’ (‘ivy-insert-current’) ............................ @@ -647,7 +652,7 @@ jjjj’ in Hydra. Toggle calling the action after each candidate change. It modifies ‘j’ to ‘jg’, ‘k’ to ‘kg’ etc. -‘m’ (‘ivy-rotate-preferred-builders’) +‘M’ (‘ivy-rotate-preferred-builders’) ..................................... Rotate the current regexp matcher. @@ -779,7 +784,7 @@ completion: (setq ivy-re-builders-alist '((read-file-name-internal . ivy--regex-fuzzy) - (t . ivy--regex-plus))) + (t . ivy--regex-plus))) Here, ‘read-file-name-internal’ is a function that is passed as the second argument to ‘completing-read’ for file name completion. @@ -1010,6 +1015,8 @@ File: ivy.info, Node: Defcustoms, Next: Actions, Prev: Faces, Up: Customizat The default behavior is to quit the completion after ‘DEL’ – a handy key to invoke after mistakenly triggering a completion. + Another common option is ‘ignore’, which does nothing. +  File: ivy.info, Node: Actions, Next: Packages, Prev: Defcustoms, Up: Customization @@ -1149,10 +1156,10 @@ File: ivy.info, Node: Example - define a new command with several actions, Pre (defun my-command-with-3-actions () (interactive) (ivy-read "test: " '("foo" "bar" "baz") - :action '(1 - ("o" my-action-1 "action 1") - ("j" my-action-2 "action 2") - ("k" my-action-3 "action 3")))) + :action '(1 + ("o" my-action-1 "action 1") + ("j" my-action-2 "action 2") + ("k" my-action-3 "action 3")))) The number 1 above is the index of the default action. Each action has its own string description for easy selection. @@ -1564,20 +1571,20 @@ argument. "Forward to `describe-function'." (interactive) (ivy-read "Describe function: " - (let (cands) - (mapatoms - (lambda (x) - (when (fboundp x) - (push (symbol-name x) cands)))) - cands) - :keymap counsel-describe-map - :preselect (ivy-thing-at-point) - :history 'counsel-describe-symbol-history - :require-match t - :action (lambda (x) - (describe-function - (intern x))) - :caller 'counsel-describe-function)) + (let (cands) + (mapatoms + (lambda (x) + (when (fboundp x) + (push (symbol-name x) cands)))) + cands) + :keymap counsel-describe-map + :preselect (ivy-thing-at-point) + :history 'counsel-describe-symbol-history + :require-match t + :action (lambda (x) + (describe-function + (intern x))) + :caller 'counsel-describe-function)) Here are the interesting features of the above function, in the order that they appear: @@ -1634,9 +1641,9 @@ narrowing) or select a candidate from the visible collection. (progn (counsel--async-command (format "locate %s '%s'" - (mapconcat #'identity counsel-locate-options " ") - (counsel--elisp-to-pcre - (ivy--regex str)))) + (mapconcat #'identity counsel-locate-options " ") + (counsel--elisp-to-pcre + (ivy--regex str)))) '("" "working...")))) ;;;###autoload @@ -1645,15 +1652,15 @@ narrowing) or select a candidate from the visible collection. INITIAL-INPUT can be given as the initial minibuffer input." (interactive) (ivy-read "Locate: " #'counsel-locate-function - :initial-input initial-input - :dynamic-collection t - :history 'counsel-locate-history - :action (lambda (file) - (with-ivy-window - (when file - (find-file file)))) - :unwind #'counsel-delete-process - :caller 'counsel-locate)) + :initial-input initial-input + :dynamic-collection t + :history 'counsel-locate-history + :action (lambda (file) + (with-ivy-window + (when file + (find-file file)))) + :unwind #'counsel-delete-process + :caller 'counsel-locate)) Here are the interesting features of the above functions, in the order that they appear: @@ -1694,18 +1701,18 @@ each displayed strings. (defun find-candidates-function (str pred _) (let ((props '(1 2)) - (strs '("foo" "foo2"))) + (strs '("foo" "foo2"))) (cl-mapcar (lambda (s p) (propertize s 'property p)) - strs - props))) + strs + props))) (defun find-candidates () (interactive) (ivy-read "Find symbols: " - #'find-candidates-function - :action (lambda (x) - (message "Value: %s" (get-text-property 0 'property x) - )))) + #'find-candidates-function + :action (lambda (x) + (message "Value: %s" + (get-text-property 0 'property x))))) Here are the interesting features of the above function: @@ -1719,8 +1726,8 @@ each displayed strings.  File: ivy.info, Node: Variable Index, Next: Keystroke Index, Prev: API, Up: Top -Variable Index -************** +9 Variable Index +**************** [index] * Menu: @@ -1732,12 +1739,12 @@ Variable Index (line 64) * ivy-backward-delete-char: File Name Completion. (line 19) * ivy-call: Key bindings for multiple selections and actions keep minibuffer open. - (line 16) + (line 19) * ivy-confirm-face: Faces. (line 34) * ivy-count-format: Defcustoms. (line 6) * ivy-current-match: Faces. (line 9) * ivy-dispatching-call: Key bindings for multiple selections and actions keep minibuffer open. - (line 26) + (line 29) * ivy-dispatching-done: Key bindings for single selection action then exit minibuffer. (line 24) * ivy-display-style: Defcustoms. (line 24) @@ -1770,7 +1777,7 @@ Variable Index * ivy-next-history-element: Key bindings that alter the minibuffer input. (line 9) * ivy-next-line-and-call: Key bindings for multiple selections and actions keep minibuffer open. - (line 36) + (line 39) * ivy-occur: Saving the current completion session to a buffer. (line 9) * ivy-occur-click: Saving the current completion session to a buffer. @@ -1789,14 +1796,14 @@ Variable Index * ivy-previous-history-element: Key bindings that alter the minibuffer input. (line 18) * ivy-previous-line-and-call: Key bindings for multiple selections and actions keep minibuffer open. - (line 47) + (line 50) * ivy-read-action: Hydra in the minibuffer. (line 65) * ivy-remote: Faces. (line 71) * ivy-restrict-to-matches: Key bindings that alter the minibuffer input. (line 40) * ivy-resume: Key bindings for multiple selections and actions keep minibuffer open. - (line 55) + (line 58) * ivy-reverse-i-search: Key bindings that alter the minibuffer input. (line 48) * ivy-rotate-preferred-builders: Hydra in the minibuffer. @@ -1818,8 +1825,8 @@ Variable Index  File: ivy.info, Node: Keystroke Index, Prev: Variable Index, Up: Top -Keystroke Index -*************** +10 Keystroke Index +****************** [index] * Menu: @@ -1855,13 +1862,13 @@ Keystroke Index * C-M-j: Key bindings for single selection action then exit minibuffer. (line 53) * C-M-m: Key bindings for multiple selections and actions keep minibuffer open. - (line 16) + (line 19) * C-M-n: Key bindings for multiple selections and actions keep minibuffer open. - (line 36) + (line 39) * C-M-o: Key bindings for multiple selections and actions keep minibuffer open. - (line 26) + (line 29) * C-M-p: Key bindings for multiple selections and actions keep minibuffer open. - (line 47) + (line 50) * C-M-y: File Name Completion. (line 41) * C-o: Hydra in the minibuffer. (line 9) @@ -1874,7 +1881,7 @@ Keystroke Index (line 26) * k: Saving the current completion session to a buffer. (line 31) -* m: Hydra in the minibuffer. +* M: Hydra in the minibuffer. (line 40) * M-i: Key bindings that alter the minibuffer input. (line 23) @@ -1910,53 +1917,53 @@ Keystroke Index  Tag Table: -Node: Top1189 -Node: Introduction3100 -Node: Installation5623 -Node: Installing from Emacs Package Manager6073 -Node: Installing from the Git repository7282 -Node: Getting started8102 -Node: Basic customization8409 -Node: Key bindings9004 -Node: Global key bindings9196 -Node: Minibuffer key bindings11670 -Node: Key bindings for navigation12902 -Node: Key bindings for single selection action then exit minibuffer14109 -Node: Key bindings for multiple selections and actions keep minibuffer open16756 -Node: Key bindings that alter the minibuffer input19223 -Node: Other key bindings21168 -Node: Hydra in the minibuffer21546 -Node: Saving the current completion session to a buffer23964 -Node: Completion Styles25376 -Node: ivy--regex-plus27127 -Node: ivy--regex-ignore-order28613 -Node: ivy--regex-fuzzy28981 -Node: Customization29478 -Node: Faces29664 -Node: Defcustoms32093 -Node: Actions33387 -Node: What are actions?33713 -Node: How can different actions be called?34531 -Node: How to modify the actions list?35102 -Node: Example - add two actions to each command35762 -Node: How to undo adding the two actions36721 -Node: How to add actions to a specific command37173 -Node: Example - define a new command with several actions37589 -Node: Test the above function with ivy-occur38477 -Node: Packages39319 -Node: Commands40284 -Node: File Name Completion40469 -Node: Using TRAMP42426 -Node: Buffer Name Completion43928 -Node: Counsel commands44543 -Node: API45190 -Node: Required arguments for ivy-read45788 -Node: Optional arguments for ivy-read46307 -Node: Example - counsel-describe-function49733 -Node: Example - counsel-locate52591 -Node: Example - ivy-read-with-extra-properties56341 -Node: Variable Index57549 -Node: Keystroke Index64669 +Node: Top1192 +Node: Introduction3103 +Node: Installation5626 +Node: Installing from Emacs Package Manager6076 +Node: Installing from the Git repository7324 +Node: Getting started8144 +Node: Basic customization8451 +Node: Key bindings9046 +Node: Global key bindings9238 +Node: Minibuffer key bindings11712 +Node: Key bindings for navigation12944 +Node: Key bindings for single selection action then exit minibuffer14151 +Node: Key bindings for multiple selections and actions keep minibuffer open16835 +Node: Key bindings that alter the minibuffer input19456 +Node: Other key bindings21403 +Node: Hydra in the minibuffer21781 +Node: Saving the current completion session to a buffer24199 +Node: Completion Styles25611 +Node: ivy--regex-plus27369 +Node: ivy--regex-ignore-order28855 +Node: ivy--regex-fuzzy29223 +Node: Customization29720 +Node: Faces29906 +Node: Defcustoms32335 +Node: Actions33694 +Node: What are actions?34020 +Node: How can different actions be called?34838 +Node: How to modify the actions list?35409 +Node: Example - add two actions to each command36069 +Node: How to undo adding the two actions37028 +Node: How to add actions to a specific command37480 +Node: Example - define a new command with several actions37896 +Node: Test the above function with ivy-occur38833 +Node: Packages39675 +Node: Commands40640 +Node: File Name Completion40825 +Node: Using TRAMP42782 +Node: Buffer Name Completion44284 +Node: Counsel commands44899 +Node: API45546 +Node: Required arguments for ivy-read46144 +Node: Optional arguments for ivy-read46663 +Node: Example - counsel-describe-function50089 +Node: Example - counsel-locate53073 +Node: Example - ivy-read-with-extra-properties56942 +Node: Variable Index58220 +Node: Keystroke Index65344  End Tag Table diff --git a/lisp/swiper.el b/lisp/swiper.el index c419ce73..14b0a62a 100644 --- a/lisp/swiper.el +++ b/lisp/swiper.el @@ -1,13 +1,13 @@ ;;; swiper.el --- Isearch with an overview. Oh, man! -*- lexical-binding: t -*- -;; Copyright (C) 2015-2020 Free Software Foundation, Inc. +;; Copyright (C) 2015-2021 Free Software Foundation, Inc. ;; Author: Oleh Krehel ;; URL: https://github.com/abo-abo/swiper -;; Package-Version: 20201208.1419 -;; Package-Commit: 71c59aecf669142ebe264fac8ff7b440c0c71712 -;; Version: 0.13.0 -;; Package-Requires: ((emacs "24.5") (ivy "0.13.0")) +;; Package-Version: 20210919.1221 +;; Package-Commit: c97ea72285f2428ed61b519269274d27f2b695f9 +;; Version: 0.13.4 +;; Package-Requires: ((emacs "24.5") (ivy "0.13.4")) ;; Keywords: matching ;; This file is part of GNU Emacs. @@ -334,19 +334,28 @@ If the input is empty, select the previous history element instead." (avy-push-mark)) (avy--done)))) +(defun swiper--avy-index (pos) + "Return `ivy--index' for `avy' candidate at minibuffer POS." + ;; Position in original buffer. + (let ((opos (get-text-property pos 'point))) + (or + ;; Find `swiper-isearch' index based on buffer position. + (and opos (cl-position opos ivy--all-candidates)) + ;; Find `swiper' index based on line number. + (let ((nlines (count-lines (point-min) (point-max)))) + (+ (car (ivy--minibuffer-index-bounds + ivy--index ivy--length ivy-height)) + (line-number-at-pos pos) + (if (or (= nlines (1+ ivy-height)) + (< ivy--length ivy-height)) + 0 + (- ivy-height nlines)) + -2))))) + (defun swiper--avy-goto (candidate) (cond ((let ((win (cdr-safe candidate))) (and win (window-minibuffer-p win))) - (let ((nlines (count-lines (point-min) (point-max)))) - (ivy-set-index - (+ (car (ivy--minibuffer-index-bounds - ivy--index ivy--length ivy-height)) - (line-number-at-pos (car candidate)) - (if (or (= nlines (1+ ivy-height)) - (< ivy--length ivy-height)) - 0 - (- ivy-height nlines)) - -2))) + (setq ivy--index (swiper--avy-index (car candidate))) (ivy--exhibit) (ivy-done) (ivy-call)) @@ -357,16 +366,19 @@ If the input is empty, select the previous history element instead." ;;;###autoload (defun swiper-avy () - "Jump to one of the current swiper candidates." + "Jump to one of the current swiper candidates with `avy'." (interactive) (unless (require 'avy nil 'noerror) - (error "Package avy isn't installed")) + (user-error "Package avy isn't installed")) (cl-case (length ivy-text) (0 (user-error "Need at least one char of input")) (1 - (let ((swiper-min-highlight 1)) - (swiper--update-input-ivy)))) + ;; FIXME: `swiper--update-input-ivy' expects string candidates, + ;; but `swiper-isearch' now uses buffer positions. + (when (stringp (ivy-state-current ivy-last)) + (let ((swiper-min-highlight 1)) + (swiper--update-input-ivy))))) (swiper--avy-goto (swiper--avy-candidate))) (declare-function mc/create-fake-cursor-at-point "ext:multiple-cursors-core") @@ -1143,11 +1155,11 @@ WND, when specified is the window." (defun swiper-from-isearch () "Invoke `swiper' from isearch." (interactive) - (let ((query (if isearch-regexp - isearch-string - (regexp-quote isearch-string)))) - (isearch-exit) - (swiper query))) + (swiper (prog1 (if isearch-regexp + isearch-string + (regexp-quote isearch-string)) + (let ((search-nonincremental-instead nil)) + (isearch-exit))))) (defvar swiper-multi-buffers nil "Store the current list of buffers.") @@ -1400,24 +1412,20 @@ See `ivy-format-functions-alist' for further information." (nreverse cands))))) (defun swiper--isearch-next-item (re cands) - (if swiper--isearch-backward - (or - (cl-position-if - (lambda (x) - (and - (< x swiper--isearch-start-point) - (eq 0 (string-match-p - re - (buffer-substring-no-properties - x swiper--isearch-start-point))))) - cands - :from-end t) - 0) - (or - (cl-position-if - (lambda (x) (> x swiper--isearch-start-point)) - cands) - 0))) + (or (if swiper--isearch-backward + (save-excursion + ;; Match RE starting at each position in CANDS. + (setq re (concat "\\=\\(?:" re "\\)")) + (cl-position-if + (lambda (x) + (when (< x swiper--isearch-start-point) + (goto-char x) + ;; Note: Not quite the same as `looking-at' + `match-end'. + (re-search-forward re swiper--isearch-start-point t))) + cands + :from-end t)) + (cl-position swiper--isearch-start-point cands :test #'<)) + 0)) (defun swiper--isearch-filter-ignore-order (re-full cands) (let (filtered-cands) @@ -1475,11 +1483,15 @@ that we search only for one character." (dolist (re (swiper--positive-regexps)) (swiper--add-overlays re)))) +(defun swiper--isearch-candidate-pos (cand) + "Return the buffer position of `swiper-isearch' CAND, or nil." + (cond ((integer-or-marker-p cand) cand) + ((and (stringp cand) (> (length cand) 0)) + (get-text-property 0 'point cand)))) + (defun swiper-isearch-action (x) "Move to X for `swiper-isearch'." - (if (or (numberp x) - (and (> (length x) 0) - (setq x (get-text-property 0 'point x)))) + (if (setq x (swiper--isearch-candidate-pos x)) (with-ivy-window (goto-char x) (when (and (or (eq this-command 'ivy-previous-line-or-history) @@ -1489,7 +1501,11 @@ that we search only for one character." (goto-char (match-beginning 0))) (funcall isearch-filter-predicate (point) (1+ (point))) (swiper--maybe-recenter) - (if (eq ivy-exit 'done) + (if (or (eq ivy-exit 'done) + ;; FIXME: With the default action 'M-o o', `ivy-exit' remains + ;; nil for some reason, so check `this-command' instead to + ;; tell whether we're "done". + (eq this-command #'ivy-dispatching-done)) (progn (swiper--push-mark) (swiper--remember-search-history (ivy--regex ivy-text))) @@ -1506,7 +1522,20 @@ that we search only for one character." (line-beginning-position) (line-end-position))) (goto-char swiper--opoint)) -(ivy-add-actions 'swiper-isearch '(("w" swiper-action-copy "copy"))) +(defun swiper-isearch-action-copy (cand) + "Save `swiper-isearch' candidate CAND to `kill-ring'. +Return to original position." + (unwind-protect + (progn + (unless (and (setq cand (swiper--isearch-candidate-pos cand)) + ;; FIXME: Better way of getting current candidate? + (goto-char cand) + (looking-back (ivy-re-to-str ivy-regex) (point-min))) + (error "Could not copy `swiper-isearch' candidate: %S" cand)) + (kill-new (match-string 0))) + (goto-char swiper--opoint))) + +(ivy-add-actions 'swiper-isearch '(("w" swiper-isearch-action-copy "copy"))) (ivy-add-actions 'swiper '(("w" swiper-action-copy "copy"))) (defun swiper-isearch-thing-at-point () @@ -1538,10 +1567,19 @@ When not running `swiper-isearch' already, start it." (setq thing (ivy-thing-at-point)))) (swiper-isearch thing)))) +(defun swiper-isearch-C-r (&optional arg) + "Move cursor vertically up ARG candidates. +When the input is empty, browse the search history instead." + (interactive "p") + (if (string= ivy-text "") + (ivy-reverse-i-search) + (ivy-previous-line arg))) + (defvar swiper-isearch-map (let ((map (make-sparse-keymap))) (set-keymap-parent map swiper-map) (define-key map (kbd "M-n") 'swiper-isearch-thing-at-point) + (define-key map (kbd "C-r") 'swiper-isearch-C-r) map) "Keymap for `swiper-isearch'.") diff --git a/lisp/versions b/lisp/versions index 990aacbf..3d0e97f8 100644 --- a/lisp/versions +++ b/lisp/versions @@ -9,20 +9,20 @@ | async | [[https://melpa.org/#/async][melpa]] | 1.9.5 | 20210823.528 | 1.9.4 | 20200809.501 | required by ob-async | | avy.el | [[https://melpa.org/#/avy][melpa]] | 0.5.0 | 20220102.805 | 0.5.0 | 20201226.1734 | | | awesome-tray.el | [[https://github.com/manateelazycat/awesome-tray][GitHub]] | 4.2 | 20211129.311 | 4.2 | 20200618.2102 | modeline in echo area | -| biblio | melpa | 0.2 | 20200416.1407 | 0.2 | 20190624.1408 | | -| biblio-core.el | melpa | 0.2.1 | 20200416.307 | 0.2 | 20190624.1408 | | -| bibtex-completion.el | melpa | 1.0.0 | 20200908.1017 | 1.0.0 | 20200513.852 | required by ivy-bibtex | -| bind-key.el | melpa | 2.4 | 20200805.1727 | 2.4 | 20191110.416 | required by use-package | -| cl-libify.el | melpa | 0 | 20181130.230 | | | prevent: Package cl is deprecated | -| company | melpa | 0.9.13 | 20210103.1124 | 0.9.12 | 20200616.2354 | | -| company-anaconda.el | melpa | 0.2.0 | 20200404.1859 | 0.2.0 | 20181025.1305 | | -| company-ledger.el | melpa | 0.1.0 | 20200726.1825 | | | | -| company-quickhelp.el | melpa | 2.2.0 | 20201208.2308 | 2.2.0 | 20200626.1245 | | -| company-web | melpa | 2.1 | 20180402.1155 | | | requires cl-lib company dash web-completion-data | -| concurrent.el | melpa | 0.5.0 | 20161229.330 | | | required by epc, requires deferred | -| counsel.el | melpa | 0.13.0 | 20201227.1327 | 0.13.0 | 20200619.1030 | | -| crdt.el | [[https://code.librehq.com/qhong/crdt.el/][librehq]] | 0.0.0 | 2020.12.28 | 0.0.0 | 2020 | Collaborative editing using Conflict-free Replicated Data Types | -| ctable.el | melpa | 0.1.2 | 20171006.11 | | | | +| biblio | [[https://melpa.org/#/biblio][melpa]] | 0.2 | 20210418.406 | 0.2 | 20200416.1407 | | +| biblio-core.el | [[https://melpa.org/#/biblio-core][melpa]] | 0.2.1 | 20210418.406 | 0.2.1 | 20200416.307 | | +| bibtex-completion.el | [[https://melpa.org/#/bibtex-completion][melpa]] | 1.0.0 | 20211019.1306 | 1.0.0 | 20200908.1017 | required by ivy-bibtex | +| bind-key.el | [[https://melpa.org/#/bind-key][melpa]] | 2.4 | 20210210.1609 | 2.4 | 20200805.1727 | required by use-package | +| cl-libify.el | [[https://melpa.org/#/cl-libify][melpa]] | 0 | 20181130.230 | | | prevent: Package cl is deprecated | +| company | [[https://melpa.org/#/company][melpa]] | 0.9.13 | 20220103.351 | 0.9.13 | 20210103.1124 | completion framework | +| company-anaconda.el | [[https://melpa.org/#/company-anaconda][melpa]] | 0.2.0 | 20200404.1859 | 0.2.0 | 20181025.1305 | | +| company-ledger.el | [[https://melpa.org/#/company-ledger][melpa]] | 0.1.0 | 20210910.250 | 0.1.0 | 20200726.1825 | | +| company-quickhelp.el | [[https://melpa.org/#/company-quickhelp][melpa]] | 2.2.0 | 20211115.1335 | 2.2.0 | 20201208.2308 | | +| company-web | [[https://melpa.org/#/company-web][melpa]] | 2.1 | 20180402.1155 | | | requires cl-lib company dash web-completion-data | +| concurrent.el | [[https://melpa.org/#/concurrent][melpa]] | 0.5.0 | 20161229.330 | | | required by epc, requires deferred | +| counsel.el | [[https://melpa.org/#/counsel][melpa]] | 0.13.4 | 20211230.1909 | 0.13.0 | 20201227.1327 | | +| crdt.el | [[https://code.librehq.com/qhong/crdt.el/][librehq]] | 0.2.7 | 2021.12.06 | 0.0.0 | 2020.12.28 | Collaborative editing using Conflict-free Replicated Data Types | +| ctable.el | [[https://melpa.org/#/ctable][melpa]] | 0.1.3 | 20210128.629 | 0.1.2 | 20171006.11 | | | dash.el | melpa | 2.17.0 | 20210106.2158 | 2.17.0 | 20200524.1947 | | | dashboard | melpa | 1.8.0-SNAPSHOT | 20210104.1605 | 1.8.0-SNAPSHOT | 20200306.1344 | requires page-break-lines, (all-the-icons) | | deferred.el | melpa | 0.5.1 | 20170901.1330 | | | required by concurrent | @@ -50,7 +50,7 @@ | hydra | melpa | 0.15.0 | 20201115.1055 | 0.15.0 | 20200608.1528 | required by org-ref | | indent-guide.el | melpa | 2.3.1 | 20191106.240 | | | | | iscroll.el | melpa | 1.0.0 | 20210128.1938 | | | | -| ivy | melpa | 0.13.0 | 20210105.2002 | 0.13.0 | 20200624.1140 | | +| ivy | [[https://melpa.org/#/ivy][melpa]] | 0.13.4 | 20211231.1730 | 0.13.0 | 20210105.2002 | | | ivy-bibtex | melpa | 1.0.1 | 20201014.803 | 1.0.1 | 20200429.1606 | | | js2-mode | melpa | 20201220 | 20201220.1718 | 20200610 | 20200610.1339 | | | key-chord.el | melpa | 0.6 | 20201222.2030 | | | required by org-ref | @@ -97,7 +97,7 @@ | sql-indent | elpa | 1.5 | - | 1.4 | - | | | srefactor | melpa | 0.3 | 20180703.1810 | | | | | stickyfunc-enhance.el | melpa | 0.1 | 20150429.1814 | | | | -| swiper.el | melpa | 0.13.0 | 20201208.1419 | 0.13.0 | 20200503.1102 | | +| swiper.el | [[https://melpa.org/#/swiper][melpa]] | 0.13.4 | 20210919.1221 | 0.13.0 | 20201208.1419 | | | systemd | melpa | | 20191219.2304 | | | | | transient | melpa | 0.2.0 | 20210103.1546 | 0.2.0 | 20200622.2050 | | | treemacs | melpa | 2.8 | 20210107.1251 | 2.8 | 20200625.2056 | |