add:did-create/rename/delete

.github/workflows/release.yaml

@@ -1,11 +1,11 @@
-# stub from https://github.com/softprops/action-gh-release
+# stub from https://github.com/softprops/action-gh-release 
 name: Release 
 on:
   push:
     tags:
       - "*.*.*"
-  pull_request:
-    branches: main
+  # pull_request:
+  #   branches: main
 
 jobs:
   build-and-release:
@@ -48,14 +48,5 @@ jobs:
       - name: Release
         uses: softprops/action-gh-release@v2
         with:
-          name: Scheme LangServer Auto-generated Build
-          tag_name: automated_build
+          repo: ufo5260987423/scheme-langserver
           files: build/scheme-langserver-x86_64-linux-glibc
-            # build/scheme-langserver-x86_64-linux-musl
-          body: |
-            This is an automated release of Scheme LangServer.
-
-            **Commit:** ${{ github.sha }}
-            **Branch:** ${{ github.ref_name }}
-            **Pipeline Run:** ${{ github.run_id }}
-

analysis/package-manager/txt-filter.sls

@@ -4,14 +4,13 @@
     (chezscheme)
     (scheme-langserver util io)
     (scheme-langserver virtual-file-system file-node)
-    (only (srfi :13 strings) string-suffix? string-prefix? string-contains string-index-right string-index string-take string-drop string-drop-right))
+    (only (srfi :13 strings) string-suffix?))
 
-(define (generate-txt-file-filter list-path)
+(define (generate-txt-file-filter)
   (lambda (path)
     ;; (pretty-print `(DEBUG: ,path)) 
     (cond
-      [(string-contains path "akku") #f]
-      [(string-suffix? ".scm.txt" path) #t]
       [(file-directory? path) #t]
+      [(string-suffix? ".scm.txt" path) #t]
       [else #f])))
 )

analysis/workspace.sls

@@ -15,18 +15,22 @@
     workspace-library-node
     workspace-library-node-set!
     workspace-file-linkage
+    workspace-facet
     workspace-type-inference?
 
     update-file-node-with-tail
 
+    attach-new-file
+    remove-new-file
+
     pick
     generate-library-node)
   (import 
     (ufo-match)
     (ufo-threaded-function)
 
     (chezscheme) 
-    (only (srfi :13 strings) string-suffix?)
+    (only (srfi :13 strings) string-suffix? string-prefix?)
 
     (scheme-langserver util path)
     (ufo-try)
@@ -85,18 +89,17 @@
     [(path identifier threaded? type-inference?) (init-workspace path identifier 'r6rs threaded? type-inference?)]
     [(path identifier top-environment threaded? type-inference?)
     ;; (pretty-print `(DEBUG: function: init-workspace))
-      (let* ([root-file-node 
-            (init-virtual-file-system path '() 
-              (cond
-                ;todo:add more filter
-                [(equal? 'r7rs top-environment) (generate-txt-file-filter (string-append path "/tests/r7rs"))]
-                [(equal? 'akku identifier) (generate-akku-acceptable-file-filter (string-append path "/.akku/list"))]
-                [else (generate-akku-acceptable-file-filter (string-append path "/.akku/list"))]))]
+      (let* ([facet 
+            (case identifier
+              [txt (generate-txt-file-filter)]
+              [akku (generate-akku-acceptable-file-filter (string-append path "/.akku/list"))]
+              [else (generate-akku-acceptable-file-filter (string-append path "/.akku/list"))])]
+          [root-file-node (init-virtual-file-system path '() facet)]
           [root-library-node (init-library-node root-file-node)]
           [file-linkage (init-file-linkage root-file-node root-library-node)]
           [batches (get-init-reference-batches file-linkage)])
         (init-references root-file-node root-library-node file-linkage threaded? batches type-inference?)
-        (make-workspace root-file-node root-library-node file-linkage identifier threaded? type-inference?))]))
+        (make-workspace root-file-node root-library-node file-linkage facet threaded? type-inference?))]))
 
 ;; head -[linkage]->files
 ;; for single file
@@ -206,12 +209,15 @@
     (let* ([linkage (workspace-file-linkage workspace-instance)]
         [root-file-node (workspace-file-node workspace-instance)]
         [root-library-node (workspace-library-node workspace-instance)]
-        [library-identifiers-list (get-library-identifiers-list (file-node-document target-file-node))]
-        [path (refresh-file-linkage&get-refresh-path linkage root-library-node target-file-node (document-index-node-list (file-node-document target-file-node)) library-identifiers-list)]
-        [path-aheadof `(,@(list-ahead-of path (file-node-path target-file-node)) ,(file-node-path target-file-node))]
-        [refreshable-path (filter (lambda (single) (document-refreshable? (file-node-document (walk-file root-file-node single)))) path-aheadof)]
-        [refreshable-batches (shrink-paths linkage refreshable-path)])
-      (init-references workspace-instance refreshable-batches))))
+        [library-identifiers-list (get-library-identifiers-list (file-node-document target-file-node))])
+      (if (null? library-identifiers-list)
+        (init-references workspace-instance `((,(file-node-path target-file-node))))
+        (let* ([path (refresh-file-linkage&get-refresh-path linkage root-library-node target-file-node (document-index-node-list (file-node-document target-file-node)) library-identifiers-list)]
+            [path-aheadof `(,@(list-ahead-of path (file-node-path target-file-node)) ,(file-node-path target-file-node))]
+            [refreshable-path (filter (lambda (single) (document-refreshable? (file-node-document (walk-file root-file-node single)))) path-aheadof)]
+            ;target-file-node may don't have library-identifiers-list
+            [refreshable-batches (shrink-paths linkage refreshable-path)])
+          (init-references workspace-instance refreshable-batches))))))
 
 (define (init-virtual-file-system path parent my-filter)
   (if (my-filter path)
@@ -227,32 +233,79 @@
               (lambda (p) 
                 (init-virtual-file-system 
                   (string-append path 
-                    (if (string-suffix? (list->string (list (directory-separator))) path)
+                    (if (string-suffix? (string (directory-separator)) path)
                       ""
-                      (list->string (list (directory-separator))))
+                      (string (directory-separator)))
                     p) 
                   node 
                   my-filter)) 
               (directory-list path))
             '())])
-      (file-node-children-set! node (filter (lambda(p) (not (null? p))) children))
+      (file-node-children-set! node (filter (lambda (p) (not (null? p))) children)) 
       node)
     '()))
 
+
+(define (remove-new-file path parent my-filter)
+  (let ([f (walk-file parent path)])
+    (cond 
+      [(not (null? f)) '()]
+      [else 
+        (file-node-children-set!
+          (file-node-parent f)
+          (filter 
+            (lambda (x) (not (equal? x f)))
+            (file-node-children (file-node-parent f))))])))
+
+(define (attach-new-file path parent my-filter)
+  (let ([f (walk-file parent path)])
+    (cond 
+      [(not (my-filter path)) '()]
+      [(not (file-exists? path)) '()]
+      [(not (null? f)) f]
+      [(file-node-folder? parent)
+        (let ([maybe-parent 
+              (find (lambda (child) (string-prefix? (file-node-path child) path))
+                (file-node-children parent))])
+          (if maybe-parent
+            (attach-new-file path maybe-parent my-filter)
+            (let ([new-node
+                  (init-virtual-file-system 
+                    (find (lambda (p) (string-prefix? p path))
+                      (map 
+                        (lambda (p) (string-append (file-node-path parent) (string (directory-separator)) p))
+                        (directory-list (file-node-path parent))))
+                    parent my-filter)])
+              (file-node-children-set! parent `(,@(file-node-children parent) ,new-node))
+              new-node)))]
+      [else 
+        (let* ([name (path->name path)] 
+            [document (init-document path)]
+            [node (make-file-node path name parent #f '() document)])
+          (file-node-children-set! parent `(,@(file-node-children parent) ,node))
+          node)])))
+
 (define (init-document path)
   (let ([uri (path->uri path)]
       [s (read-string path)])
-    (if (string? s)
-      (try
-        (make-document 
-          uri 
-          s
-          (map (lambda (item) (init-index-node '() item)) (source-file->annotations path))
-          (find-meta '(chezscheme)))
-        (except c
-          [(equal? c 'can-not-tolerant) '()]
-          [else '()]))
-      '())))
+    (try
+      (cond 
+        [(string? s) 
+          (make-document 
+            uri 
+            s
+            (map (lambda (item) (init-index-node '() item)) (source-file->annotations path))
+            (find-meta '(chezscheme)))]
+        [(eof-object? s) 
+          (make-document 
+            uri 
+            ""
+            '()
+            (find-meta '(chezscheme)))]
+        [else '()])
+      (except c
+        [(equal? c 'can-not-tolerant) '()]
+        [else '()]))))
 
 (define init-library-node
   (case-lambda 

protocol/apis/file-change-notification.sls

@@ -0,0 +1,75 @@
+(library (scheme-langserver protocol apis file-change-notification)
+  (export 
+    did-create
+    did-delete
+    did-rename)
+  (import 
+    (chezscheme) 
+
+    (scheme-langserver analysis workspace)
+    (scheme-langserver analysis identifier reference)
+
+    (scheme-langserver protocol alist-access-object)
+
+    (scheme-langserver util association)
+    (scheme-langserver util path) 
+    (ufo-try) 
+    (scheme-langserver util text) 
+    (scheme-langserver util io)
+
+    (scheme-langserver virtual-file-system index-node)
+    (scheme-langserver virtual-file-system document)
+    (scheme-langserver virtual-file-system file-node)
+
+    (scheme-langserver analysis package-manager akku)
+    (scheme-langserver analysis package-manager txt-filter)
+
+    (only (srfi :13 strings) string-replace))
+
+; https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#workspace_didCreateFiles
+(define (did-create workspace params)
+  (let* ([files (vector->list (assq-ref params 'files))]
+      [uris (map (lambda (file) (assq-ref file 'uri)) files)]
+      [paths (map uri->path uris)]
+      [facet (workspace-facet workspace)]
+      [root-file-node (workspace-file-node workspace)])
+    (map 
+      (lambda (file-node)
+        (refresh-workspace-for workspace file-node))
+      (map 
+        (lambda (path) (attach-new-file path root-file-node facet))
+        paths))))
+
+; https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#workspace_didRenameFiles
+(define (did-rename workspace params)
+  (map 
+    (lambda (file)
+      (let* ([old (assq-ref file 'oldUri)]
+          [old-path (uri->path old)]
+          [old-file-node (walk-file (workspace-file-node workspace) old-path)]
+          [new (assq-ref file 'newUri)]
+          [new-path (uri->path new)]
+          [root-file-node (workspace-file-node workspace)]
+          [facet (workspace-facet workspace)]
+          [new-file-node (attach-new-file new-path root-file-node facet)])
+        (file-node-document-set! new-file-node (file-node-document old-file-node))))
+    (vector->list (assq-ref params 'files))))
+
+;https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#workspace_didDeleteFiles
+(define (did-delete workspace params)
+  (let* ([files (vector->list (assq-ref params 'files))]
+      [uris (map (lambda (file) (assq-ref file 'uri)) files)]
+      [paths (map uri->path uris)])
+    (map 
+      (lambda (file-node)
+        (if (file-node? file-node)
+          (file-node-children-set!
+            (file-node-parent file-node)
+            (filter 
+              (lambda (siblins)
+                (not (equal? file-node siblins)))
+              (file-node-children (file-node-parent file-node))))))
+      (map 
+        (lambda (path) (walk-file (workspace-file-node workspace) path))
+        paths))))
+)

scheme-langserver.sls

@@ -24,6 +24,7 @@
     (scheme-langserver protocol apis document-sync)
     (scheme-langserver protocol apis document-symbol)
     (scheme-langserver protocol apis document-diagnostic)
+    (scheme-langserver protocol apis file-change-notification)
 
     (scheme-langserver util association)
     (scheme-langserver util path))
@@ -65,6 +66,10 @@
         ["textDocument/didClose" (did-close workspace params)]
         ["textDocument/didChange" (did-change workspace params)]
 
+        ["workspace/didCreateFiles" (did-create workspace params)]
+        ["workspace/didRenameFiles" (did-rename workspace params)]
+        ["workspace/didDeleteFiles" (did-delete workspace params)]
+
         ["textDocument/hover" (send-message server-instance (success-response id (hover workspace params)))]
         ["textDocument/completion" (send-message server-instance (success-response id (completion workspace params)))]
         ["textDocument/references" (send-message server-instance (success-response id (find-references workspace params)))]
@@ -151,6 +156,14 @@
               'documentSymbolProvider #t
               ; 'documentLinkProvider #t
               'documentFormattingProvider #f
+              'workspace 
+                (make-alist 'fileOperations 
+                  (make-alist 
+                  ;however, these three are only triggered when create/rename/delete file with vscode's origin create/renmae/delete
+                  ;so that we must to add fault tolerant to re-init workspace
+                    'didCreate (make-alist 'filters (vector (make-alist 'scheme "file" 'pattern (make-alist 'glob "**/*"))))
+                    'didRename (make-alist 'filters (vector (make-alist 'scheme "file" 'pattern (make-alist 'glob "**/*"))))
+                    'didDelete (make-alist 'filters (vector (make-alist 'scheme "file" 'pattern (make-alist 'glob "**/*"))))))
               ; 'documentRangeFormattingProvider #f
               ; 'documentOnTypeFormattingProvider (make-alist 'firstTriggerCharacter ")" 'moreTriggerCharacter (vector "\n" "]"))
               ; 'codeLensProvider #t

tests/analysis/test-workspace.sps

@@ -76,12 +76,11 @@
 (test-end)
 
 (test-begin "init-workspace-basic-test")
-(let* ([workspace (init-workspace (current-directory) 'akku 'r7rs #f #f)]
-       [root-file-node (workspace-file-node workspace)]
-       [root-library-node (workspace-library-node workspace)])
-  ;; (pretty-print `(DEBUG: workspace ,workspace))
-  (test-equal #f (null? root-file-node))
-  (test-equal #f (null? root-library-node)))
+(let* ([workspace (init-workspace (string-append (current-directory) "/tests/resources/r7rs") 'txt 'r7rs #f #f)]
+        [root-file-node (workspace-file-node workspace)]
+        [root-library-node (workspace-library-node workspace)])
+    (test-equal #f (null? root-file-node))
+    (test-equal #f (null? root-library-node)))
 (test-end)
 
 (exit (if (zero? (test-runner-fail-count (test-runner-get))) 0 1))