From 404c5801f816b045bb6d41dd5cdda637de91bb36 Mon Sep 17 00:00:00 2001 From: Spencer Baugh Date: Mon, 6 May 2024 18:52:21 -0400 Subject: [PATCH] Rewrite merlin-completion-at-point integration to be faster and better The merlin-completion-at-point integration before was simple and slow. The new version is much faster and much more featureful: - Completions are requested for an entire module at once and filtered locally in Emacs rather than doing the filtering on the Merlin side. - Completions are cached based on the OCaml atom being completed, so they are re-used instead of re-requested when a new character is typed. - Those completions are cached for a given position inside an OCaml atom, so that if a user types Lima to complete "List.map" and then decides they actually want the module "Labels", when they delete the "ist.map" part and hit , they'll use the previously-requested completions. - We avoid updating Merlin with the new buffer contents as completion proceeds, so that Merlin doesn't need to re-parse and re-type-check, substantially improving performance in expensive files. (merlin-cap--omit-bounds) - Completion requests are handled asynchronously and reused, so that if completion is interrupted and then resumed, we're able to use the results of the previous completion request. This makes completion UIs which use while-no-input (like corfu-mode) much more performant. - Completion is wrapped in while-no-input when non-essential is set; this makes completion UIs which don't use while-no-input (like company-mode) much more responsive. - Completions are sorted more intelligently: if they're a constructor or variant or label, they're likely to be more relevant to the user, so they're sorted first. - Module names in completions are suffixed with a ., matching Emacs behavior for file name completion (where directories are suffixed with a /); this makes completion of module paths much more fluent, since there's no need to hit . after every module name. - We use completion boundaries, so the built-in Emacs partial-completion feature now works: if the user types "Li.ma", it will complete to "List.map". - Likewise, partial-completion will expand * as a glob, so if the user types "Deferred.*.map" they will be presented with every module in "Deferred." which contains the method "map" There are also several tests now, testing the new functionality. --- emacs/merlin-cap.el | 721 +++++++++++++++++++++++++++++++++++++++++--- emacs/merlin.el | 115 +++---- 2 files changed, 739 insertions(+), 97 deletions(-) diff --git a/emacs/merlin-cap.el b/emacs/merlin-cap.el index 70e0aece68..16c73a9f26 100644 --- a/emacs/merlin-cap.el +++ b/emacs/merlin-cap.el @@ -9,65 +9,704 @@ ;; Keywords: ocaml languages ;; URL: http://github.com/ocaml/merlin -(require 'merlin) +;;; Commentary: ;; Call merlin-completion-at-point when you want merlin guided completion-at-point. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Code: + +(require 'merlin) +(require 'subr-x) + +(defvar-local merlin-cap--cache nil + "An alist mapping contexts to lists of completions. -;; Internal variables +This is used to cache completions; it is indexed by the return +value of `merlin-completion-prefix'. -(defvar-local merlin-cap--table nil - "Hold a table mapping completion candidates to their types.") +The keys are strings like \"List.\" or the empty string. +The values are lists of completion strings.") -(defvar-local merlin-cap--cache (cons "" 0) - "The cache for calls to completion-at-point so that it does not -trigger useless merlin calls.") +(defvar-local merlin-cap--cache-position nil + "The position for which `merlin-cap--cache' is valid.") ;; Internal functions -(defun merlin-cap--lookup (string _state) - "Lookup the entry STRING inside the completion table." - (let ((ret (assoc string merlin-cap--table))) - (if ret (message "%s%s" (car ret) (cdr ret))))) +(defun merlin-cap--exit-function (string _state) + "Print a message for completion STRING." + (let ((ret (merlin-cap--annotate string))) + (if ret (message "%s%s" string ret)))) (defun merlin-cap--annotate (candidate) - "Retrieve the annotation for candidate CANDIDATE in -`merlin-completion-annotate-table'." - (cdr (assoc candidate merlin-cap--table))) + "Retrieve the annotation for candidate CANDIDATE." + ;; Fancy completion styles (like partial-completion) can concatenate multiple candidates + ;; together into a single candidate (e.g. "List." and "map" concatenated into "List.map"), + ;; and each component of that will have its own annotation text property. + ;; We want to print the type of the overall expression, so grab the annotation from the end. + (get-text-property (1- (length candidate)) 'merlin-cap--annotation candidate)) + +(defvar merlin-cap--interrupt-symbol nil) + +(define-error 'merlin-cap--test-interrupt "Test-only interrupt") +(defun merlin-cap--interrupt-in-test (position-symbol) + "Error if POSITION-SYMBOL is equal to `merlin-cap--interrupt-symbol'." + (when (eq position-symbol merlin-cap--interrupt-symbol) + (signal 'merlin-cap--test-interrupt position-symbol))) + +(defvar-local merlin-cap--process-last-event nil + "The most recent process event for a Merlin process in this buffer.") + +(defun merlin-cap--sentinel (process event) + "Store EVENT in `merlin-cap--process-last-event' in PROCESS's buffer." + (let ((buf (process-buffer process))) + (when (buffer-live-p buf) + (with-current-buffer buf + (setq merlin-cap--process-last-event event))))) + +;; Buffer-local variables for request buffers +(defvar-local merlin-cap--request-debug-cons nil + "This request's entry in the variable `merlin-debug-last-commands'. + +This is a cons whose cdr starts out nil, is set to the symbol +`pending' when the request is fully created, and is set to the +raw output string from the request when it's completed.") +(defvar-local merlin-cap--request-stderr-proc nil + "The stderr pipe process for this request.") +(defvar-local merlin-cap--request-originating-buffer nil + "The buffer that this completion request is for.") +(defvar-local merlin-cap--request-position nil + "The POSITION argument to `merlin-cap--complete-prefix' for this request.") +(defvar-local merlin-cap--request-prefix nil + "The PREFIX argument to `merlin-cap--complete-prefix' for this request.") +(defvar-local merlin-cap--request-ignore-region nil + "The IGNORE-REGION argument to `merlin-cap--complete-prefix' for this request.") + +(defun merlin-cap--pending-request (position ignore-region) + "Return a pre-existing request for POSITION and IGNORE-REGION. + +Specifically, return a cons whose car is the prefix that the +request was for and whose cdr is the request buffer. Return nil +if no pending request exists, or its inputs do not match." + (let ((buf (current-buffer))) + (with-current-buffer (get-buffer-create " *merlin-async-proc-stdout*" t) + (when (and (eq (cdr merlin-cap--request-debug-cons) 'pending) + (eq buf merlin-cap--request-originating-buffer) + (eql position merlin-cap--request-position) + (equal ignore-region merlin-cap--request-ignore-region)) + (cons merlin-cap--request-prefix + (current-buffer)))))) + +(defun merlin-cap--complete-prefix (position prefix omit-region) + "Request completions that could come after PREFIX at POSITION. + +POSITION is some position in the current buffer. It doesn't need +to actually have PREFIX before it. + +Returns the buffer that the data from Merlin will be inserted +into; this should be waited for with +`merlin-cap--wait-for-request'. + +When sending the current buffer to Merlin, we ignore the region +at OMIT-REGION, which is a cons of the start and end." + (let* ((buffer (with-current-buffer (get-buffer-create " *merlin-async-proc-stdout*" t) + (when-let ((proc (get-buffer-process (current-buffer)))) + (delete-process proc)) + (when merlin-cap--request-stderr-proc + (delete-process merlin-cap--request-stderr-proc)) + (fundamental-mode) + (erase-buffer) + (merlin-cap--interrupt-in-test 'prepare-buffer) + (current-buffer))) + (process-environment (merlin--process-environment)) + (command (cons (merlin-command) + (merlin--command-args "complete-prefix" + "-position" (merlin-unmake-point position) + "-prefix" prefix))) + (debug-cons (cons command nil)) + (stderr-proc (make-pipe-process + :name "merlin complete-prefix stderr" + :buffer (get-buffer-create " *merlin-async-proc-stderr*" t) + :noquery t))) + (unwind-protect + (progn + (push debug-cons merlin-debug-last-commands) + (merlin-cap--interrupt-in-test 'make-stderr-proc) + (let ((proc (make-process + :name "merlin complete-prefix" + :buffer buffer + :stderr stderr-proc + :command command + :connection-type 'pipe + :noquery t + :sentinel #'merlin-cap--sentinel))) + (unwind-protect + (progn + (merlin-cap--interrupt-in-test 'make-main-proc) + (save-restriction + ;; The current narrowing might be syntactically invalid, so widen first + (widen) + (process-send-region proc (point-min) (car omit-region)) + (merlin-cap--interrupt-in-test 'sent-half-input) + (process-send-region proc (cdr omit-region) (point-max)) + (process-send-eof proc)) + (merlin-cap--interrupt-in-test 'sent-eof) + (let ((originating-buffer (current-buffer))) + (with-current-buffer buffer + (setq-local merlin-cap--request-debug-cons debug-cons + merlin-cap--request-stderr-proc stderr-proc + merlin-cap--request-originating-buffer originating-buffer + merlin-cap--request-position position + merlin-cap--request-prefix prefix))) + (setcdr debug-cons 'pending) + buffer) + (unless (eq (cdr debug-cons) 'pending) + (delete-process proc))))) + (unless (eq (cdr debug-cons) 'pending) + (delete-process stderr-proc))))) + +(defun merlin-cap--wait-for-request (request-buffer) + "Wait for the process in REQUEST-BUFFER, then parse and return its output." + (with-current-buffer request-buffer + (cl-assert (eq (cdr merlin-cap--request-debug-cons) 'pending)) + (when-let ((proc (get-buffer-process (current-buffer)))) + ;; The process may have already finished and been deleted; but if it's still around, + ;; wait for it. + (while (accept-process-output proc)) + ;; Ensure that the sentinel runs. + (delete-process proc)) + (delete-process merlin-cap--request-stderr-proc) + (merlin-cap--interrupt-in-test 'process-finished) + (setcdr merlin-cap--request-debug-cons (buffer-string)) + (unless (equal merlin-cap--process-last-event "finished\n") + (error "merlin-cap--wait-for-request: %s %s" merlin-cap--process-last-event (cdr merlin-cap--request-debug-cons))) + (goto-char (point-min)) + (let ((result (read (current-buffer)))) + (cl-assert (= (1+ (point)) (point-max)) + "This request buffer contains more than one response from Merlin?") + (merlin-cap--interrupt-in-test 'read-buffer) + (merlin--handle-result (nth 0 (car merlin-cap--request-debug-cons)) + (nth 1 (car merlin-cap--request-debug-cons)) + result)))) + +(defcustom merlin-cap-dot-after-module t + "Automatically add a dot after completing a module name. + +Specifically, the completion strings returned for modules have a +\".\" appended to them which is included when accepting a module +as a completion. For example, when this is non-nil, the List +module is completed as \"List.\" rather than \"List\". + +This is convenient when completing a value name like +\"Foo.Bar.baz\", since you don't have to type \".\" after +completing \"Foo\" and \"Bar\". When completing a module name +like \"(module Foo.Bar)\", this is less convenient, since you +need to remove the trailing dot after completing \"Bar\". Since +the former is much more common than the latter, this is on by +default. + +This also has a non-obvious effect: when module names have a dot +after them, partial completion works substantially better. For +example, if this is on, `completion-at-point' will complete +\"Li.map\" to \"List.map\". + +The reason for this is somewhat hard to explain, but essentially +the partial completion style tries to expand the module path by +expanding the glob \"Li*.\". That expands to \"List.\" but not +to \"List\" because the latter doesn't include the trailing dot." + :type 'boolean + :group 'merlin) + +(defun merlin-cap--process-completion-data (completion-data prefix) + "Process COMPLETION-DATA from Merlin into an alist of completion to description. +PREFIX should be the prefix used to request this data." + (let (ret) + ;; Collect all the normal completion entries + (dolist (entry (alist-get 'entries completion-data)) + (let ((name (alist-get 'name entry))) + ;; We could delay some of this work to merlin-cap--annotate, + ;; but it doesn't help much in benchmarks. + (put-text-property + 0 (length name) 'merlin-cap--annotation + (let ((kind (alist-get 'kind entry)) + (desc (replace-regexp-in-string "[\n ]+" " " (alist-get 'desc entry)))) + (cond + ((equal kind "Module") + (if merlin-cap-dot-after-module + (progn + (setq name (concat name ".")) + nil) + ": ")) + ((equal kind "Type") + (format ": [%s]" desc)) + ((equal kind "Label") + (concat ": " desc)) + ((member kind '("Constructor" "Variant")) + (put-text-property 0 (length name) 'merlin-cap--sort-early t name) + (concat ": " desc)) + (t (concat ": " desc)))) + name) + (push name ret))) + ;; Only include labels if there's no Dotted.Context. before the completion region + (when (string-empty-p prefix) + (dolist (label (alist-get 'labels (car (cdr-safe (alist-get 'context completion-data))))) + (let ((name (alist-get 'name label)) + (type (alist-get 'type label))) + (put-text-property 0 (length name) 'merlin-cap--sort-early t name) + (put-text-property 0 (length name) 'merlin-cap--annotation (concat ": " type) name) + (push name ret) + (when (= (aref name 0) ??) + (let ((tilde-name (substring name)) + (tilde-type (string-remove-suffix " option" type))) + (aset tilde-name 0 ?~) + (put-text-property 0 (length tilde-name) 'merlin-cap--annotation (concat ": " tilde-type) tilde-name) + (push tilde-name ret)))))) + (nreverse ret))) + +(defun merlin-cap--omit-bounds () + "Return a region around point to omit when requesting Merlin completions." + (let* ((atom (merlin-cap--atom-bounds)) + ;; By default, we omit the entire atom... + (omit-start (car atom)) + (omit-end (cdr atom)) + (is-label (memq (char-after omit-start) '(?~ ?? ?`)))) + (unless is-label + ;; ...except, to work around the lack of https://github.com/ocaml/merlin/issues/1751 + ;; we can't omit the entire atom if we're in a record projection. Merlin ignores + ;; PREFIX when determining what record we're projecting from, and only looks at the + ;; buffer contents. To support that, lower-case components before point in the + ;; buffer must be included. + (save-excursion + ;; Go to the start of the current component... + (skip-chars-backward "a-z0-9A-Z_'") + (setq omit-start (point)) + ;; ...and skip backwards over uppercase components only, or components starting + ;; with a star (to allow for partial-completion globbing) + (while (and (not (zerop (skip-chars-backward "."))) + (not (zerop (skip-chars-backward "a-z0-9A-Z_*'"))) + (let ((first-char (char-after (point)))) + (or (eq 'Lu (get-char-code-property first-char 'general-category)) + (eq first-char ?*)))) + (setq omit-start (point))))) + (cons omit-start omit-end))) + +(defun merlin-cap--display-sort-predicate (a b) + "Sort completions A and B alphabetically, with a text property overriding." + (let ((a-early (get-text-property 0 'merlin-cap--sort-early a)) + (b-early (get-text-property 0 'merlin-cap--sort-early b))) + (cond + ((and a-early (not b-early)) t) + ((and (not a-early) b-early) nil) + ;; Don't sort early completions alphabetically; merlin returns them + ;; grouped them together by kind. + ((and a-early b-early) nil) + (t (string-lessp a b))))) + +(defun merlin-cap--display-sort (completions) + "Sort COMPLETIONS with `merlin-cap--display-sort-predicate'." + (sort completions #'merlin-cap--display-sort-predicate)) + +(defun merlin-cap--get-completions (prefix) + "Get (and cache) completions for PREFIX in the current buffer. + +Specifically this returns an alist mapping completion candidates, +which don't include PREFIX, to a string description of the +completion. + +Completions are cached in `merlin-cap--cache'." + (let* ((omit-bounds (merlin-cap--omit-bounds)) + ;; point is inside omit-bounds, so just return the start of + ;; the omitted region as the position. + (position (car omit-bounds))) + ;; Invalidate the cache whenever the position we're completing at has changed, or + ;; the buffer contents (outside omit-bounds) has changed. The latter is expensive + ;; to check, though, so we only check if the position has changed. That's close + ;; enough, since a change before the position will probably change the position. + (when (or (null merlin-cap--cache-position) (/= merlin-cap--cache-position position)) + (setq-local merlin-cap--cache-position position) + (setq-local merlin-cap--cache nil)) + (let ((entry (assoc prefix merlin-cap--cache))) + ;; If there is a pending request running whose prefix/position/buffer + ;; matches this one, just wait for it to return a result. + (unless entry + (when-let ((request (merlin-cap--pending-request position omit-bounds))) + (let ((data (merlin-cap--wait-for-request (cdr request)))) + (let ((request-entry (cons (car request) (merlin-cap--process-completion-data data prefix)))) + (push request-entry merlin-cap--cache) + (when (equal (car request-entry) prefix) + (setq entry request-entry)))))) + ;; Otherwise, send a new request to merlin + (unless entry + (if (string-search "*" prefix) + ;; Merlin will incorrectly return completions when we have + ;; a star in the prefix, even though that's not a valid + ;; module name, so just forcibly return nothing. + (progn + (setq entry (cons prefix nil)) + (push entry merlin-cap--cache)) + (let* ((request-buffer (merlin-cap--complete-prefix position prefix omit-bounds)) + (data (merlin-cap--wait-for-request request-buffer))) + (setq entry (cons prefix (merlin-cap--process-completion-data data prefix))) + (push entry merlin-cap--cache)))) + (cdr entry)))) + +(defun merlin-cap--last-position (needle haystack) + "Get the index of the start of the last occurence of NEEDLE in HAYSTACK." + (when-let ((pos (string-search needle (reverse haystack)))) + (- (length haystack) pos))) (defun merlin-cap--table (string pred action) - "Implement completion for merlin using `completion-at-point' API." - (if (eq 'metadata action) - (when merlin-completion-types - '(metadata ((annotation-function . merlin-cap--annotate) - (exit-function . merlin-cap--lookup)))) - (complete-with-action action merlin-cap--table string pred))) + "Implement completion for merlin using `completion-at-point' API. + +Does programmed completion using STRING, PRED, and ACTION; see +Info node `(elisp)Programmed Completion'. + +This caches completions in `merlin-cap--cache'." + (let* ((last-dot-position (merlin-cap--last-position "." string)) + (context (if last-dot-position (substring string 0 last-dot-position) "")) + (component (if last-dot-position (substring string last-dot-position) string))) + (cond + ((eq action 'metadata) + (list 'metadata + (cons 'display-sort-function #'merlin-cap--display-sort) + (cons 'annotation-function (when merlin-completion-types #'merlin-cap--annotate)))) + ((and (consp action) (eq (car action) 'boundaries)) + (let ((start (length context)) + (end (string-search "." (cdr action)))) + ;; include the . in the boundaries + (when end (setq end (1+ end))) + (cons 'boundaries (cons start end)))) + (t + (let ((completions + ;; Wrap in while-no-input if we're in what seems to be an idle completion, so that we + ;; don't block the user. + (if non-essential + (let ((ret (while-no-input (merlin-cap--get-completions context)))) + (if (eq ret t) + ;; Interrupted by while-no-input, just complete on an empty list. + '() + ret)) + ;; Use with-local-quit in case something in our call stack binds + ;; inhibit-quit; without this, our blocking calls to accept-process-output + ;; will result in warnings being messaged. + (with-local-quit (merlin-cap--get-completions context))))) + (cond + ((null action) + (let ((ret (try-completion component completions pred))) + (cond + ((eq ret t) t) + ((null ret) nil) + ;; When try-completion returns a string, that string should cover the entire + ;; completion region, not just the last component. + (t (concat context ret))))) + ((eq action t) (all-completions component completions pred)) + ((eq action 'lambda) (test-completion component completions pred)))))))) + +(defun merlin-cap--atom-bounds () + "This is like `merlin-bounds-of-ocaml-atom-at-point', but correct. + +Also, this function treats \"*\" as a normal alphanumeric +character. When partial-completion is in `completion-styles' (as +it is by default), this allows including arbitrary globs in the +middle of an OCaml atom and completing over them. +The bounds returned by that function incorrectly omit a \".\" +found at the end of the atom. Also, it treats \"~foo.bar\" as an +atom." + (let (atom-start atom-end) + (save-excursion + (skip-chars-backward "a-z0-9A-Z*_'") + ;; Either skip over a single label-starting character, or a Dotted.Ocaml.atom + (when (zerop (skip-chars-backward "?`~" (1- (point)))) + (skip-chars-backward "a-z0-9A-Z*_'.")) + (setq atom-start (point)) + ;; We may not have actually moved backwards at all, in which case we'll be + ;; returning an atom found after point, possibly a label. + (if (zerop (skip-chars-forward "?`~" (1+ (point)))) + (skip-chars-forward "a-z0-9A-Z*_'.") + (skip-chars-forward "a-z0-9A-Z*_'")) + (setq atom-end (point))) + (cons atom-start atom-end))) ;; Public functions (defun merlin-cap () - "Perform completion at point with merlin." - (let* - ((bounds (merlin-completion-bounds)) - (start (car bounds)) - (end (cdr bounds)) - (prefix (merlin-buffer-substring start end)) - (compl-prefix (merlin-completion-prefix prefix))) - (when (or (not merlin-cap--cache) - (not (equal (cons prefix start) merlin-cap--cache))) - (setq merlin-cap--cache (cons prefix start)) - (setq merlin-cap--table - (mapcar - (lambda (a) - (cons (merlin-completion-entry-text compl-prefix a) - (concat ": " (merlin-completion-entry-short-description a)))) - (merlin-complete prefix)))) - (list start end #'merlin-cap--table - . (:exit-function #'merlin-cap--lookup - :annotation-function #'merlin-cap--annotate)))) + "Perform completion at point with merlin. + +This completes only on the current fragment; e.g., with point at +the end of \"Aaa.bbb.ccc\", the current fragment is \"ccc\", and +we'll request all completions for \"Aaa.bbb.\" and filter them +down in Emacs. This means if we backspace and type +\"Aaa.bbb.ddd\" instead, we won't need to re-request completions. + +This caches completions between calls as long as we're completing +on the same ocaml atom at the same position, as determined by +`merlin-cap--atom-bounds'." + (let ((atom (merlin-cap--atom-bounds))) + (list (car atom) (cdr atom) + #'merlin-cap--table + :exit-function (when merlin-completion-types #'merlin-cap--exit-function)))) + +(defun merlin-cap--split-on-boundaries (prefix suffix table) + "Split PREFIX and SUFFIX using `completion-boundaries' from TABLE. + +Returns a list of the string before the boundaries, within the +boundaries, and after the boundaries." + (let ((boundaries (completion-boundaries prefix table nil suffix))) + (list + (substring-no-properties prefix 0 (car boundaries)) + (concat (substring-no-properties prefix (car boundaries)) + (substring-no-properties suffix 0 (cdr boundaries))) + (substring-no-properties suffix (cdr boundaries))))) + +(defun merlin-cap--regions (prefix suffix) + "Split PREFIX and SUFFIX with `merlin-cap' as if point was between them. + +Returns: +- the part of the completion region before point that will be + included when we send the buffer contents to Merlin +- the part of the completion region before the current completion + boundaries, which is what will be sent to Merlin as \"-prefix\" +- the contents of the current completion boundaries +- the part of the OCaml atom after the current completion boundaries + +This function is only used for testing." + (with-temp-buffer + (insert "?before-ignored ") + (insert prefix) + (save-excursion (insert suffix) (insert "?after-ignored ")) + (let ((cap (let ((merlin-cap-dot-after-module t)) (merlin-cap)))) + (cons + (buffer-substring-no-properties (nth 0 cap) (car (merlin-cap--omit-bounds))) + (merlin-cap--split-on-boundaries + (buffer-substring-no-properties (nth 0 cap) (point)) + (buffer-substring-no-properties (point) (nth 1 cap)) + (nth 2 cap)))))) + +(ert-deftest test-merlin-cap--bounds () + (should (equal (merlin-cap--regions "Aaa.bbb.c" "cc.ddd") + '("Aaa.bbb." "Aaa.bbb." "ccc." "ddd"))) + (should (equal (merlin-cap--regions "~fo" "o.bar") + '("" "" "~foo" ""))) + (should (equal (merlin-cap--regions "" "~foo.bar") + '("" "" "~foo" ""))) + (should (equal (merlin-cap--regions "~fo" "o~bar") + '("" "" "~foo" ""))) + (should (equal (merlin-cap--regions "~foo" "~bar") + '("" "" "~foo" ""))) + (should (equal (merlin-cap--regions "~fo" "o.b~ar") + '("" "" "~foo" ""))) + ;; There's no obvious correct thing to return in this case, so this is fine. + (should (equal (merlin-cap--regions "~foo.bar" "") + '("foo." "foo." "bar" ""))) + (should (equal (merlin-cap--regions "" "~") + '("" "" "~" ""))) + (should (equal (merlin-cap--regions "" "Aaa.bbb.ccc.ddd") + '("" "" "Aaa." "bbb.ccc.ddd"))) + (should (equal (merlin-cap--regions "A" "aa.bbb.ccc.ddd") + '("" "" "Aaa." "bbb.ccc.ddd"))) + ;; An "atom" can also just be a dotted path projecting from an expression + (should (equal (merlin-cap--regions "(foo bar)." "") + '("." "." "" ""))) + (should (equal (merlin-cap--regions "(foo bar).Aa" "a") + '("." "." "Aaa" ""))) + (should (equal (merlin-cap--regions "(foo bar).Aaa.Bb" "b.ccc") + '("." ".Aaa." "Bbb." "ccc"))) + (should (equal (merlin-cap--regions "(foo bar).Aaa.bb" "b.ccc") + '("." ".Aaa." "bbb." "ccc"))) + (should (equal (merlin-cap--regions "(foo bar).aaa.bb" "b.ccc") + '(".aaa." ".aaa." "bbb." "ccc"))) + ;; We should omit only uppercase components before point, not lowercase ones + (should (equal (merlin-cap--regions "M." "x") + '("" "M." "x" ""))) + (should (equal (merlin-cap--regions "M.t." "x") + '("M.t." "M.t." "x" ""))) + (should (equal (merlin-cap--regions "M.N." "x") + '("" "M.N." "x" ""))) + (should (equal (merlin-cap--regions "M.t.N." "x") + '("M.t." "M.t.N." "x" ""))) + (should (equal (merlin-cap--regions "aa.bB.CC.x" "") + '("aa.bB." "aa.bB.CC." "x" ""))) + (should (equal (merlin-cap--regions "Aa.bB.CC.x" "") + '("Aa.bB." "Aa.bB.CC." "x" ""))) + (should (equal (merlin-cap--regions "aa.Bb.cc.x" "") + '("aa.Bb.cc." "aa.Bb.cc." "x" ""))) + (should (equal (merlin-cap--regions "aa.Bb.Cc.x" "") + '("aa." "aa.Bb.Cc." "x" "")))) + +(defun merlin-cap--current-message () + "Like `current-message' but work in batch mode and use `messages-buffer-name'." + (with-current-buffer messages-buffer-name + (save-excursion + (forward-line -1) + (buffer-substring (point) (pos-eol))))) + +(defmacro merlin-cap--with-test-buffer (&rest body) + "Run BODY with a temp buffer set up for Merlin completion." + `(with-temp-buffer + (merlin-mode) + (setq-local completion-at-point-functions '(merlin-cap)) + (insert " +module Mmaa = struct + module Mmbb = struct + type ttaa = { ffaa : int } + type ttbb = { ffbb : ttaa } + let (vvaa : ttbb) = { ffbb = { ffaa = 0 } } + ;; + end +end + +let () = ") + ;; Don't log during the tests + (let ((merlin-client-log-function nil)) + ,@body))) + +(defun merlin-cap--test-complete (prefix suffix new-prefix new-suffix message) + "Trigger completion with point between PREFIX and SUFFIX and compare results. + +NEW-PREFIX and NEW-SUFFIX are what's before and after point after +completion, and MESSAGE is the message printed." + (let ((start (point))) + (insert prefix) + (save-excursion (insert suffix)) + ;; clear any previous message, to avoid coalescing [no message] + (message "\n") + (message "[no message]") + (completion-at-point) + (let ((end (pos-eol)) + ;; Just so the ERT error renders more nicely + (point (point))) + (should (equal (list (buffer-substring start point) + (buffer-substring point end) + (merlin-cap--current-message)) + (list new-prefix new-suffix message)))) + (delete-region start (pos-eol)))) + +(ert-deftest test-merlin-cap-completion () + (with-temp-buffer + (let ((messages-buffer-name (buffer-name (current-buffer)))) + (merlin-cap--with-test-buffer + (let ((merlin-cap-dot-after-module nil)) + (merlin-cap--test-complete "Mma" "" + "Mmaa" "" + "Mmaa: ") + (merlin-cap--test-complete "Mmaa.Mmb" "" + "Mmaa.Mmbb" "" + "Mmaa.Mmbb: ") + (merlin-cap--test-complete "Mmaa.Mmbb.vva" "" + "Mmaa.Mmbb.vvaa" "" + "Mmaa.Mmbb.vvaa: Mmaa.Mmbb.ttbb")) + ;; Manually clear the cache, since the differences produced by + ;; `merlin-cap-dot-after-module' are persisted in the cache. + (setq-local merlin-cap--cache nil) + (let ((merlin-cap-dot-after-module t)) + (merlin-cap--test-complete "Mma" "" + "Mmaa." "" + "[no message]") + (merlin-cap--test-complete "Mmaa.Mmb" "" + "Mmaa.Mmbb." "" + "[no message]") + (merlin-cap--test-complete "Mmaa.Mmbb.vva" "" + "Mmaa.Mmbb.vvaa" "" + "Mmaa.Mmbb.vvaa: Mmaa.Mmbb.ttbb") + (should (equal (length merlin-cap--cache) 3)) + (merlin-cap--test-complete "Mmaa.Mmbb.vvaa.ff" "" + "Mmaa.Mmbb.vvaa.ffbb" "" + "Mmaa.Mmbb.vvaa.ffbb: Mmaa.Mmbb.ttbb -> Mmaa.Mmbb.ttaa") + ;; When completing inside a record we have to include the record name in the + ;; buffer contents sent to Merlin; that invalidates the cache + (should (equal (length merlin-cap--cache) 1)) + (merlin-cap--test-complete "Mmaa.Mmbb.vvaa.ffbb.ff" "" + "Mmaa.Mmbb.vvaa.ffbb.ffaa" "" + "Mmaa.Mmbb.vvaa.ffbb.ffaa: Mmaa.Mmbb.ttaa -> int") + ;; We're completing in a new part of the record, so again the cache is invalidated + (should (equal (length merlin-cap--cache) 1)) + ;; completion in the middle of the atom + (merlin-cap--test-complete "Mmaa.Mmb" ".vva" + "Mmaa.Mmbb." "vva" + "[no message]") + ;; partial completion (PCM) + (setq-local merlin-cap--cache nil) + (merlin-cap--test-complete "Mma.Mmb.vva" "" + "Mmaa.Mmbb.vvaa" "" + "Mmaa.Mmbb.vvaa: Mmaa.Mmbb.ttbb") + ;; The cache entries appear in reverse order of PCM's lookups; + ;; first it looks up the existing string, removing a component from the end each time it finds no results; + ;; eventually PCM just has "Mma." and it queries for "" to find completions, and it finds "Mmaa."; + ;; from there it can query for "Mmaa." and "Mmaa.Mmbb." to find completions and expand each component. + (should (equal (reverse (mapcar #'car merlin-cap--cache)) + '("Mma.Mmb." "Mma." "" "Mmaa." "Mmaa.Mmbb."))) + ;; partial completion with a glob + (merlin-cap--test-complete "Mma.*.vva" "" + "Mmaa.Mmbb.vvaa" "" + "Mmaa.Mmbb.vvaa: Mmaa.Mmbb.ttbb") + ;; When PCM looks up "Mma.*." and gets no results, that's how it knows it is safe to glob instead. + (should (member "Mma.*." (mapcar #'car merlin-cap--cache))) + ;; completion with no results + (merlin-cap--test-complete "Mmaa.Mmbbxxx." "" + "Mmaa.Mmbbxxx." "" + "No match") + ;; The lack of results is cached. + (should (equal (length merlin-cap--cache) 7)) + ;; completion in and after a parenthesized expression + (merlin-cap--test-complete "(Mmaa.Mmbb.vv" "" + "(Mmaa.Mmbb.vvaa" "" + "Mmaa.Mmbb.vvaa: Mmaa.Mmbb.ttbb") + (merlin-cap--test-complete "(Mmaa.Mmbb.vvaa).ffb" "" + "(Mmaa.Mmbb.vvaa).ffbb" "" + ".ffbb: Mmaa.Mmbb.ttbb -> Mmaa.Mmbb.ttaa") + ;; We're completing after a different expression, so no caching. + (should (equal (length merlin-cap--cache) 1)) + (merlin-cap--test-complete "((fun x -> x) Mmaa.Mmbb.vvaa).ffbb.ffa" "" + "((fun x -> x) Mmaa.Mmbb.vvaa).ffbb.ffaa" "" + ".ffbb.ffaa: Mmaa.Mmbb.ttaa -> int")))))) + +(ert-deftest test-merlin-cap-interrupts () + "Test that `merlin-cap' is robust to being interrupted. + +At least at some hardcoded interruption points." + (merlin-cap--with-test-buffer + (let (syms) + ;; Collect the interruption position symbols + (cl-letf (((symbol-function 'merlin-cap--interrupt-in-test) + (lambda (sym) (push sym syms)))) + (merlin-cap--get-completions "")) + ;; Make sure we're actually doing something + (should (> (length syms) 3)) + ;; For each position, interrupt at that position. + (dolist (sym-to-interrupt syms) + (let ((procs (process-list))) + (let ((merlin-cap--interrupt-symbol sym-to-interrupt)) + ;; Interrupt it a few times, in case there's only an error the + ;; second or third time. + (should-error (merlin-cap--get-completions "Mmaa.") + :type 'merlin-cap--test-interrupt) + ;; Also with a different prefix. + (should-error (merlin-cap--get-completions "Non.existent.Thing.") + :type 'merlin-cap--test-interrupt) + (should-error (merlin-cap--get-completions "Mmaa.") + :type 'merlin-cap--test-interrupt)) + (should (equal (merlin-cap--get-completions "Mmaa.") '("Mmbb"))) + ;; Remove the cache entry added by that presumably-successful completion. + (setq merlin-cap--cache nil) + ;; All the created processes have been deleted + (should (equal (cl-set-difference (process-list) procs) '()))))))) + +(ert-deftest test-merlin-cap-closed-pipe () + "Test the Merlin server is robust to an EPIPE caused by Emacs. + +We delete the Merlin client process without sending all input, +which causes the Merlin server to get EPIPE from all IO, which +it's had bugs with before. + +Reliably reproducing these errors may require increasing the +count in `dotimes'." + (merlin-cap--with-test-buffer + (dotimes (_ 10) + (dotimes (_ 3) + (let ((merlin-cap--interrupt-symbol 'sent-half-input)) + (should-error (merlin-cap--get-completions "Mmaa.Mmbb.") + :type 'merlin-cap--test-interrupt))) + (should (equal (merlin-cap--get-completions "Mmaa.") '("Mmbb")))))) (defalias 'merlin-completion-at-point 'merlin-cap) diff --git a/emacs/merlin.el b/emacs/merlin.el index 9100dfa360..8b4ea47309 100644 --- a/emacs/merlin.el +++ b/emacs/merlin.el @@ -508,55 +508,51 @@ return (LOC1 . LOC2)." (delete-file tmp)))) result))) +(defun merlin--process-environment () + "Return the `process-environment' value for an immediate Merlin call. + +This should not be saved, since it depends on the current +`process-environment'." + ;; for simplicity, we use a mere append here (leading to a + ;; duplicate binding), it does work because only the first + ;; occurrence is considered, one can check this by running + ;; (call-process "printenv" nil t) + (append (merlin-lookup 'env merlin-buffer-configuration) process-environment)) + +(defun merlin--command-args (command &rest args) + "Return a list of arguments for calling Merlin COMMAND with ARGS." + (when (eq merlin-verbosity-context t) + (setq merlin-verbosity-context (cons command args))) + (if (not merlin-verbosity-context) + (setq merlin--verbosity-cache nil) + (if (equal merlin-verbosity-context (car-safe merlin--verbosity-cache)) + (setcdr merlin--verbosity-cache (1+ (cdr merlin--verbosity-cache))) + (setq merlin--verbosity-cache (cons merlin-verbosity-context 0)))) + (merlin--map-flatten-to-string + "server" command "-protocol" "sexp" + (when-let ((dot-merlin (merlin-lookup 'dot-merlin merlin-buffer-configuration))) + (list "-dot-merlin" dot-merlin)) + (when merlin-debug + '("-log-file" "-")) + (when merlin-verbosity-context + (list "-verbosity" (cdr merlin--verbosity-cache))) + (when merlin-buffer-packages-path + (list "-I" merlin-buffer-packages-path)) + (when merlin-buffer-extensions + (list "-extension" merlin-buffer-extensions)) + (unless (string-equal merlin-buffer-flags "") + (cons "-flags" merlin-buffer-flags)) + (when-let ((filename (buffer-file-name (buffer-base-buffer)))) + (cons "-filename" filename)) + args)) + (defun merlin--call-merlin (command &rest args) "Invoke merlin binary with the proper setup to execute the command passed as argument (lookup appropriate binary, setup logging, pass global settings)" ;; Really start process (let ((binary (merlin-command)) - ;; (flags (merlin-lookup 'flags merlin-buffer-configuration)) - (process-environment - ;; for simplicity, we use a mere append here (leading to a - ;; duplicate binding), it does work because only the first - ;; occurrence is considered, one can check this by running - ;; (call-process "printenv" nil t) - (append (merlin-lookup 'env merlin-buffer-configuration) - process-environment)) - (dot-merlin (merlin-lookup 'dot-merlin merlin-buffer-configuration)) - ;; FIXME use logfile - ;; (logfile (or (merlin-lookup 'logfile merlin-buffer-configuration) - ;; merlin-logfile)) - (extensions (merlin--map-flatten (lambda (x) (cons "-extension" x)) - merlin-buffer-extensions)) - (packages (merlin--map-flatten (lambda (x) (cons "-I" x)) - merlin-buffer-packages-path)) - (filename (buffer-file-name (buffer-base-buffer)))) - ;; Compute verbosity - (when (eq merlin-verbosity-context t) - (setq merlin-verbosity-context (cons command args))) - (if (not merlin-verbosity-context) - (setq merlin--verbosity-cache nil) - (if (equal merlin-verbosity-context (car-safe merlin--verbosity-cache)) - (setcdr merlin--verbosity-cache (1+ (cdr merlin--verbosity-cache))) - (setq merlin--verbosity-cache (cons merlin-verbosity-context 0)))) - ;; Compute full command line. - (setq args (merlin--map-flatten-to-string - "server" command "-protocol" "sexp" - (when dot-merlin - (list "-dot-merlin" dot-merlin)) - ;; Is debug mode enabled - (when merlin-debug '("-log-file" "-")) - ;; If command is repeated, increase verbosity - (when merlin-verbosity-context - (list "-verbosity" (cdr merlin--verbosity-cache))) - packages - extensions - (unless (string-equal merlin-buffer-flags "") - (cons "-flags" merlin-buffer-flags)) - (when filename - (cons "-filename" filename)) - (when merlin-cache-lifespan - (cons "-cache-lifespan" (number-to-string merlin-cache-lifespan))) - args)) + (process-environment (merlin--process-environment)) + (args (merlin--command-args command args))) ;; Log last commands (setq merlin-debug-last-commands (cons (cons (cons binary args) nil) merlin-debug-last-commands)) @@ -584,18 +580,25 @@ argument (lookup appropriate binary, setup logging, pass global settings)" (quit (merlin-client-logger binary command -1 "interrupted") (signal (car err) (cdr err)))) - (let* ((notifications (cdr-safe (assoc 'notifications result))) - (timing (cdr-safe (assoc 'timing result))) - (class (cdr-safe (assoc 'class result))) - (value (cdr-safe (assoc 'value result)))) - (merlin-client-logger binary command timing class) - (dolist (notification notifications) - (message "(merlin) %s" notification)) - (pcase class - ("return" value) - ("failure" (error "merlin-mode failure: %s" value)) - ("error" (error "merlin: %s" value)) - (_ (error "unknown answer: %S:%S" class value)))))) + (merlin--handle-result binary command result))) + +(defun merlin--handle-result (binary command result) + "Turn the parsed sexp RESULT into an error, if it's a Merlin error. + +Also, print a message for any Merlin notifications, using BINARY +and COMMAND." + (let* ((notifications (cdr-safe (assoc 'notifications result))) + (timing (cdr-safe (assoc 'timing result))) + (class (cdr-safe (assoc 'class result))) + (value (cdr-safe (assoc 'value result)))) + (merlin-client-logger binary command timing class) + (dolist (notification notifications) + (message "(merlin) %s" notification)) + (pcase class + ("return" value) + ("failure" (error "merlin-mode failure: %s" value)) + ("error" (error "merlin: %s" value)) + (_ (error "unknown answer: %S:%S" class value))))) (define-obsolete-function-alias 'merlin/call 'merlin-call "2021-01-27")