[elpa] externals/eglot 50b0e84 22/49: Fix #602: fully handle LSP glob syntax

[Stefan Monnier]

branch: externals/eglot
commit 50b0e8485e76a0b89ff067db22f58e8d88d76f83
Author: João Távora <joaotavora@gmail.com>
Commit: João Távora <joaotavora@gmail.com>

    Fix #602: fully handle LSP glob syntax
    
    Thanks to Brian Leung and Dan Peterson for testing and helping me spot
    bugs.
    
    * eglot-tests.el (eglot--glob-match): New test.
    
    * eglot.el (eglot--wildcard-to-regexp): Delete.
    (eglot-register-capability): Rework.
    (eglot--glob-parse, eglot--glob-compile, eglot--glob-emit-self)
    (eglot--glob-emit-**, eglot--glob-emit-*, eglot--glob-emit-?)
    (eglot--glob-emit-{}, eglot--glob-emit-range)
    (eglot--directories-recursively): New helpers.
---
 eglot-tests.el |  55 ++++++++++++++++++++++++++++
 eglot.el       | 113 +++++++++++++++++++++++++++++++++++++++++++++------------
 2 files changed, 144 insertions(+), 24 deletions(-)

diff --git a/eglot-tests.el b/eglot-tests.el
index 852b65a..f081afa 100644
--- a/eglot-tests.el
+++ b/eglot-tests.el
@@ -1044,6 +1044,61 @@ will assume it exists."
       (should (equal guessed-class 'eglot-lsp-server))
       (should (equal guessed-contact '("some-executable"))))))
 
+(defun eglot--glob-match (glob str)
+  (funcall (eglot--glob-compile glob t t) str))
+
+(ert-deftest eglot--glob-test ()
+  (should (eglot--glob-match "foo/**/baz" "foo/bar/baz"))
+  (should (eglot--glob-match "foo/**/baz" "foo/baz"))
+  (should-not (eglot--glob-match "foo/**/baz" "foo/bar"))
+  (should (eglot--glob-match "foo/**/baz/**/quuz" "foo/baz/foo/quuz"))
+  (should (eglot--glob-match "foo/**/baz/**/quuz" "foo/foo/foo/baz/foo/quuz"))
+  (should-not (eglot--glob-match "foo/**/baz/**/quuz" 
"foo/foo/foo/ding/foo/quuz"))
+  (should (eglot--glob-match "*.js" "foo.js"))
+  (should-not (eglot--glob-match "*.js" "foo.jsx"))
+  (should (eglot--glob-match "foo/**/*.js" "foo/bar/baz/foo.js"))
+  (should-not (eglot--glob-match "foo/**/*.js" "foo/bar/baz/foo.jsx"))
+  (should (eglot--glob-match "*.{js,ts}" "foo.js"))
+  (should-not (eglot--glob-match "*.{js,ts}" "foo.xs"))
+  (should (eglot--glob-match "foo/**/*.{js,ts}" "foo/bar/baz/foo.ts"))
+  (should (eglot--glob-match "foo/**/*.{js,ts}x" "foo/bar/baz/foo.tsx"))
+  (should (eglot--glob-match "?oo.js" "foo.js"))
+  (should (eglot--glob-match "foo/**/*.{js,ts}?" "foo/bar/baz/foo.tsz"))
+  (should (eglot--glob-match "foo/**/*.{js,ts}?" "foo/bar/baz/foo.tsz"))
+  (should (eglot--glob-match "example.[!0-9]" "example.a"))
+  (should-not (eglot--glob-match "example.[!0-9]" "example.0"))
+  (should (eglot--glob-match "example.[0-9]" "example.0"))
+  (should-not (eglot--glob-match "example.[0-9]" "example.a"))
+  (should (eglot--glob-match "**/bar/" "foo/bar/"))
+  (should-not (eglot--glob-match "foo.hs" "fooxhs"))
+
+  ;; Some more tests
+  (should (eglot--glob-match "**/.*" ".git"))
+  (should (eglot--glob-match ".?" ".o"))
+  (should (eglot--glob-match "**/.*" ".hidden.txt"))
+  (should (eglot--glob-match "**/.*" "path/.git"))
+  (should (eglot--glob-match "**/.*" "path/.hidden.txt"))
+  (should (eglot--glob-match "**/node_modules/**" "node_modules/"))
+  (should (eglot--glob-match "{foo,bar}/**" "foo/test"))
+  (should (eglot--glob-match "{foo,bar}/**" "bar/test"))
+  (should (eglot--glob-match "some/**/*" "some/foo.js"))
+  (should (eglot--glob-match "some/**/*" "some/folder/foo.js"))
+
+  ;; VSCode supposedly supports this, not sure if good idea.
+  ;;
+  ;; (should (eglot--glob-match "**/node_modules/**" "node_modules"))
+  ;; (should (eglot--glob-match "{foo,bar}/**" "foo"))
+  ;; (should (eglot--glob-match "{foo,bar}/**" "bar"))
+
+  ;; VSCode also supports nested blobs.  Do we care?
+  ;;
+  ;; (should (eglot--glob-match "{**/*.d.ts,**/*.js}" "/testing/foo.js"))
+  ;; (should (eglot--glob-match "{**/*.d.ts,**/*.js}" "testing/foo.d.ts"))
+  ;; (should (eglot--glob-match "{**/*.d.ts,**/*.js,foo.[0-9]}" "foo.5"))
+  ;; (should (eglot--glob-match "prefix/{**/*.d.ts,**/*.js,foo.[0-9]}" 
"prefix/foo.8"))
+  )
+
+
 (provide 'eglot-tests)
 ;;; eglot-tests.el ends here
 
diff --git a/eglot.el b/eglot.el
index 8403e5d..51ed1c4 100644
--- a/eglot.el
+++ b/eglot.el
@@ -2606,40 +2606,32 @@ at point.  With prefix argument, prompt for 
ACTION-KIND."
 
 ;;; Dynamic registration
 ;;;
-(defun eglot--wildcard-to-regexp (wildcard)
-  "(Very lame attempt to) convert WILDCARD to a Elisp regexp."
-  (cl-loop
-   with substs = '(("{" . "\\\\(")
-                   ("}" . "\\\\)")
-                   ("," . "\\\\|"))
-   with string = (wildcard-to-regexp wildcard)
-   for (pattern . rep) in substs
-   for target = string then result
-   for result = (replace-regexp-in-string pattern rep target)
-   finally return result))
-
 (cl-defmethod eglot-register-capability
   (server (method (eql workspace/didChangeWatchedFiles)) id &key watchers)
   "Handle dynamic registration of workspace/didChangeWatchedFiles"
   (eglot-unregister-capability server method id)
   (let* (success
-         (globs (mapcar (eglot--lambda ((FileSystemWatcher) globPattern)
-                          globPattern)
-                        watchers))
-         (glob-dirs
-          (delete-dups (mapcar #'file-name-directory
-                               (mapcan #'file-expand-wildcards globs)))))
+         (globs (mapcar
+                 (eglot--lambda ((FileSystemWatcher) globPattern)
+                   (cons
+                    (eglot--glob-compile globPattern t t)
+                    (eglot--glob-compile
+                     (replace-regexp-in-string "/[^/]*$" "/" globPattern) t 
t)))
+                 watchers))
+         (dirs-to-watch
+          (cl-loop for dir in (eglot--directories-recursively)
+                   when (cl-loop for g in globs
+                                 thereis (ignore-errors (funcall (cdr g) dir)))
+                   collect dir)))
     (cl-labels
         ((handle-event
           (event)
           (pcase-let ((`(,desc ,action ,file ,file1) event))
             (cond
              ((and (memq action '(created changed deleted))
-                   (cl-find file globs
+                   (cl-find file (mapcar #'car globs)
                             :test (lambda (f glob)
-                                    (string-match (eglot--wildcard-to-regexp
-                                                   (expand-file-name glob))
-                                                  f))))
+                                    (funcall glob f))))
               (jsonrpc-notify
                server :workspace/didChangeWatchedFiles
                `(:changes ,(vector `(:uri ,(eglot--path-to-uri file)
@@ -2652,13 +2644,13 @@ at point.  With prefix argument, prompt for 
ACTION-KIND."
               (handle-event `(,desc 'created ,file1)))))))
       (unwind-protect
           (progn
-            (dolist (dir glob-dirs)
+            (dolist (dir dirs-to-watch)
               (push (file-notify-add-watch dir '(change) #'handle-event)
                     (gethash id (eglot--file-watches server))))
             (setq
              success
              `(:message ,(format "OK, watching %s directories in %s watchers"
-                                 (length glob-dirs) (length watchers)))))
+                                 (length dirs-to-watch) (length watchers)))))
         (unless success
           (eglot-unregister-capability server method id))))))
 
@@ -2670,6 +2662,79 @@ at point.  With prefix argument, prompt for ACTION-KIND."
   (list t "OK"))
 
 
+;;; Glob heroics
+;;;
+(defun eglot--glob-parse (glob)
+  "Compute list of (STATE-SYM EMITTER-FN PATTERN)."
+  (with-temp-buffer
+    (save-excursion (insert glob))
+    (cl-loop
+     with grammar = '((:**      "\\*\\*/?"              eglot--glob-emit-**)
+                      (:*       "\\*"                   eglot--glob-emit-*)
+                      (:?       "\\?"                   eglot--glob-emit-?)
+                      (:/       "/"                     eglot--glob-emit-self)
+                      (:{}      "{[^][/*{}]+}"          eglot--glob-emit-{})
+                      (:range   "\\[\\^?[^][/,*{}]+\\]" eglot--glob-emit-range)
+                      (:literal "[^][/,*?{}]+"          eglot--glob-emit-self))
+     until (eobp)
+     collect (cl-loop
+              for (_token regexp emitter) in grammar
+              thereis (and (re-search-forward (concat "\\=" regexp) nil t)
+                           (list (cl-gensym "state-") emitter (match-string 
0)))
+              finally (error "Glob '%s' invalid at %s" (buffer-string) 
(point))))))
+
+(defun eglot--glob-compile (glob &optional byte-compile noerror)
+  "Convert GLOB into Elisp function.  Maybe BYTE-COMPILE it.
+If NOERROR, return predicate, else erroring function."
+  (let* ((states (eglot--glob-parse glob))
+         (body `(with-temp-buffer
+                  (save-excursion (insert string))
+                  (cl-labels ,(cl-loop for (this that) on states
+                                       for (self emit text) = this
+                                       for next = (or (car that) 'eobp)
+                                       collect (funcall emit text self next))
+                    (or (,(caar states))
+                        (error "Glob done but more unmatched text: '%s'"
+                               (buffer-substring (point) (point-max)))))))
+         (form `(lambda (string) ,(if noerror `(ignore-errors ,body) body))))
+    (if byte-compile (byte-compile form) form)))
+
+(defun eglot--glob-emit-self (text self next)
+  `(,self () (re-search-forward ,(concat "\\=" (regexp-quote text))) (,next)))
+
+(defun eglot--glob-emit-** (_ self next)
+  `(,self () (or (ignore-errors (save-excursion (,next)))
+                 (and (re-search-forward "\\=/?[^/]+/?") (,self)))))
+
+(defun eglot--glob-emit-* (_ self next)
+  `(,self () (re-search-forward "\\=[^/]")
+          (or (ignore-errors (save-excursion (,next))) (,self))))
+
+(defun eglot--glob-emit-? (_ self next)
+  `(,self () (re-search-forward "\\=[^/]") (,next)))
+
+(defun eglot--glob-emit-{} (arg self next)
+  (let ((alternatives (split-string (substring arg 1 (1- (length arg))) ",")))
+    `(,self ()
+            (or ,@(cl-loop for alt in alternatives
+                           collect `(re-search-forward ,(concat "\\=" alt) nil 
t))
+                (error "Failed matching any of %s" ',alternatives))
+            (,next))))
+
+(defun eglot--glob-emit-range (arg self next)
+  (when (eq ?! (aref arg 1)) (aset arg 1 ?^))
+  `(,self () (re-search-forward ,(concat "\\=" arg)) (,next)))
+
+(defun eglot--directories-recursively (&optional dir)
+  "Because `directory-files-recursively' isn't complete in 26.3."
+  (cons (setq dir (expand-file-name (or dir default-directory)))
+        (cl-loop
+         with default-directory = dir
+         with completion-regexp-list = '("^[^.]")
+         for f in (file-name-all-completions "" dir)
+         when (file-directory-p f) append (eglot--directories-recursively f))))
+
+
 ;;; Rust-specific
 ;;;
 (defclass eglot-rls (eglot-lsp-server) () :documentation "Rustlang's RLS.")