Add support for textDocument/documentHighlight

src/fennel-ls/handlers.fnl

@@ -46,7 +46,7 @@ Every time the client sends a message, it gets handled by a function in the corr
          ;; :typeDefinitionProvider nil
          ;; :implementationProvider nil
          :referencesProvider {:workDoneProgress false}
-         ;; :documentHighlightProvider nil
+         :documentHighlightProvider {:workDoneProgress false}
          ;; :documentSymbolProvider nil
          :codeActionProvider {:workDoneProgress false}
          ;; :codeLensProvider nil
@@ -96,6 +96,29 @@ Every time the client sends a message, it gets handled by a function in the corr
         (message.range-and-uri server result.file (or result.binding result.definition)))
       (catch _ nil))))
 
+;; DocumentHighlightKind
+(local documentHighlightKind
+       {:Text 1 :Read 2 :Write 3})
+
+(λ requests.textDocument/documentHighlight [server _send {: position
+                                                           :textDocument {: uri}}]
+  (let [file (files.get-by-uri server uri)
+        byte (utils.position->byte file.text position server.position-encoding)]
+    (case-try (analyzer.find-symbol file.ast byte)
+      symbol
+      (analyzer.find-nearest-definition server file symbol byte)
+      (where definition (not= definition.referenced-by nil))
+      (let [result (icollect [_ {: symbol} (ipairs definition.referenced-by)]
+                     {:range (message.ast->range server definition.file symbol)
+                      :kind documentHighlightKind.Read})]
+          (table.insert result
+            {:range (message.ast->range server definition.file definition.binding)
+             :kind documentHighlightKind.Write})
+
+        ;; TODO don't include duplicates
+        result)
+      (catch _ nil))))
+
 (λ requests.textDocument/references [server _send {: position
                                                     :textDocument {: uri}
                                                     :context {:includeDeclaration ?include-declaration?}}]

test/document-highlight.fnl

@@ -0,0 +1,49 @@
+(local faith (require :faith))
+(local {: create-client} (require :test.utils))
+(local {: null} (require :dkjson))
+(local {: view} (require :fennel))
+
+(fn range-comparator [a b]
+    (or (< a.range.start.line b.range.start.line)
+        (and (= a.range.start.line b.range.start.line)
+             (or (< a.range.start.character b.range.start.character)
+                 (and (= a.range.start.character b.range.start.character)
+                     (or (< a.range.end.line b.range.end.line)
+                         (and (= a.range.end.line b.range.end.line)
+                             (or (< a.range.end.character b.range.end.character)
+                                 (= a.range.end.character b.range.end.character)))))))))
+
+(fn check [file-contents]
+  (let [{: client : uri : cursor : highlights} (create-client file-contents)
+        [response] (client:document-highlight uri cursor)]
+    (if (not= null response.result)
+      (do
+        (table.sort highlights range-comparator)
+        (table.sort response.result range-comparator)
+        ;; Override kind in the result because utils.parse-markup doesn't have
+        ;; a way to express it. The ranges are more important.
+        (each [i v (ipairs response.result)]
+          (set v.kind 1)
+          (set (. response.result i) v))
+        (faith.= highlights response.result
+                 (view file-contents)))
+      (faith.= highlights []))))
+
+(fn test-references []
+  (check "(let [==x== 10] ==x==|)")
+  (check "(let [==x==| 10] ==x==)")
+  (check "(let [==x==| 10] ==x== ==x== ==x==)")
+  (check "(fn ==x== []) ==x|==")
+  (check "(fn ==x== []) ==|x==")
+  (check "(fn ==x==| []) ==x==")
+  (check "(fn x [])| x")
+  (check "(let [==x== nil] ==|x.y== ==x.z==)")
+  (check "(let [==x== nil] ==x|.y== ==x.z==)")
+  (check "(let [x nil] x.|y x.z)")
+  (check "(let [x nil] x.y| x.z)")
+  (check "(let [==x==| 10]
+            (print ==x==)
+            (let [x :shadowed] x))")
+  nil)
+
+{: test-references}

test/init.fnl

@@ -21,6 +21,7 @@
        :test.hover
        :test.completion
        :test.references
+       :test.document-highlight
        :test.lint
        :test.code-action
        :test.rename

test/utils/client.fnl

@@ -49,6 +49,12 @@
       :textDocument {:uri file}
       :context {:includeDeclaration (not (not ?includeDeclaration))}})))
 
+(fn document-highlight [self file position]
+  (dispatch.handle* self.server
+    (message.create-request (next-id! self) :textDocument/documentHighlight
+     {: position
+      :textDocument {:uri file}})))
+
 (fn rename [self file position newName]
   (dispatch.handle* self.server
     (message.create-request (next-id! self) :textDocument/rename
@@ -76,6 +82,7 @@
              : definition
              : hover
              : references
+             : document-highlight
              : rename
              : code-action
              : did-save}})

test/utils/init.fnl

@@ -51,7 +51,8 @@
         server {:preload (if provide-root-uri {})}
         client (doto {: server :prev-id 1}
                      (setmetatable client-mt))
-        locations []]
+        locations []
+        highlights []]
     ;; NOT main.fnl
     (each [name contents (pairs file-contents)]
       (if (not= name :main.fnl)
@@ -59,13 +60,18 @@
               {: text : ranges} (parse-markup contents opts.markup-encoding)]
           (icollect [_ range (ipairs ranges) &into locations]
             {: range : uri})
+          (icollect [_ range (ipairs ranges) &into highlights]
+            {: range :kind 1})
           (client:pretend-this-file-exists! uri text))))
     ;; main.fnl
     (let [uri (.. ROOT-URI "/" :main.fnl)
           main-file-contents (. file-contents :main.fnl)
           {: text : ranges : cursor} (parse-markup main-file-contents opts.markup-encoding)
-          _ (icollect [_ range (ipairs ranges) &into locations]
+          _ (do
+              (icollect [_ range (ipairs ranges) &into locations]
                 {: range : uri})
+              (icollect [_ range (ipairs ranges) &into highlights]
+                {: range :kind 1}))
 
           params {:capabilities {:general {:positionEncodings (un-nil (or opts.position-encodings [default-encoding]))}}
                   :clientInfo (un-nil (or opts.client-info {:name "Neovim" :version "0.7.2"}))
@@ -89,6 +95,7 @@
          : diagnostics
          : cursor
          : locations
+         : highlights
          : text
          : uri
          : initialize-response