From 97d155df58159d4a2bd9220f6d1e81feb23f1fbd Mon Sep 17 00:00:00 2001 From: ufo5260987423 Date: Mon, 7 Jul 2025 11:05:54 +0800 Subject: [PATCH 1/3] add:did-create/rename/delete fix fix fix:server capability fix:please refer the comment in scheme-langserver.sls test:did-create/delete test:did-create/delete fix:please refer the comment in scheme-langserver.sls fix fix fix fix fix fix --- analysis/package-manager/txt-filter.sls | 7 +- analysis/workspace.sls | 111 +++++++++++++----- protocol/apis/file-change-notification.sls | 75 ++++++++++++ scheme-langserver.sls | 13 ++ tests/analysis/test-workspace.sps | 11 +- .../apis/test-file-change-notification.sps | 65 ++++++++++ tests/resources/did-create.json | 6 + tests/resources/did-delete.json | 5 + 8 files changed, 254 insertions(+), 39 deletions(-) create mode 100644 protocol/apis/file-change-notification.sls create mode 100755 tests/protocol/apis/test-file-change-notification.sps create mode 100644 tests/resources/did-create.json create mode 100644 tests/resources/did-delete.json diff --git a/analysis/package-manager/txt-filter.sls b/analysis/package-manager/txt-filter.sls index 96bc88e8..49a343f1 100644 --- a/analysis/package-manager/txt-filter.sls +++ b/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]))) ) \ No newline at end of file diff --git a/analysis/workspace.sls b/analysis/workspace.sls index f76f2a26..a5beccf5 100644 --- a/analysis/workspace.sls +++ b/analysis/workspace.sls @@ -15,10 +15,14 @@ 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 @@ -26,7 +30,7 @@ (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 diff --git a/protocol/apis/file-change-notification.sls b/protocol/apis/file-change-notification.sls new file mode 100644 index 00000000..a05d7e74 --- /dev/null +++ b/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)))) +) \ No newline at end of file diff --git a/scheme-langserver.sls b/scheme-langserver.sls index 3172a29f..ae9feab6 100644 --- a/scheme-langserver.sls +++ b/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 diff --git a/tests/analysis/test-workspace.sps b/tests/analysis/test-workspace.sps index 153a6eba..5364ee48 100755 --- a/tests/analysis/test-workspace.sps +++ b/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)) diff --git a/tests/protocol/apis/test-file-change-notification.sps b/tests/protocol/apis/test-file-change-notification.sps new file mode 100755 index 00000000..8c4b6a6b --- /dev/null +++ b/tests/protocol/apis/test-file-change-notification.sps @@ -0,0 +1,65 @@ +#!/usr/bin/env scheme-script +;; -*- mode: scheme; coding: utf-8 -*- !# +;; Copyright (c) 2022 WANG Zheng +;; SPDX-License-Identifier: MIT +#!r6rs + +(import (rnrs (6)) (srfi :64 testing) (scheme-langserver) (scheme-langserver util io) (ufo-thread-pool)) + +(test-begin "file change notification") +(let* ( [shutdown-json (read-string "./tests/resources/shutdown.json")] + [shutdown-header (string-append + ; "GET /example.http HTTP/1.1\r\n" + "Content-Length: " + (number->string (bytevector-length (string->utf8 shutdown-json))) + "\r\n\r\n")] + + [initialization-json (string-append + "{\n" + " \"id\": \"1\",\n" + " \"method\": \"initialize\",\n" + " \"params\": {\n" + " \"processId\": 1,\n" + " \"rootPath\": \"" (current-directory) "\",\n" + " \"rootUri\": \"file://" (current-directory) "\",\n" + " \"capabilities\": {}\n" + " },\n" + " \"jsonrpc\": \"2.0\"\n" + "}")] + [init-header (string-append + ; "GET /example.http HTTP/1.1\r\n" + "Content-Length: " + (number->string (bytevector-length (string->utf8 initialization-json))) + "\r\n\r\n")] + + [did-create-json (format (read-string "./tests/resources/did-create.json") (current-directory))] + [did-create-header (string-append + ; "GET /example.http HTTP/1.1\r\n" + "Content-Length: " + (number->string (bytevector-length (string->utf8 did-create-json))) + "\r\n\r\n")] + + [did-delete-json (format (read-string "./tests/resources/did-delete.json") (current-directory))] + [did-delete-header (string-append + ; "GET /example.http HTTP/1.1\r\n" + "Content-Length: " + (number->string (bytevector-length (string->utf8 did-delete-json))) + "\r\n\r\n")] + + [input-port (open-bytevector-input-port (string->utf8 + (string-append + init-header initialization-json + + did-delete-header did-delete-json + did-create-header did-create-json + + shutdown-header shutdown-json)))] + [log-port (open-file-output-port "~/scheme-langserver.log" (file-options replace) 'block (make-transcoder (utf-8-codec)))] + ; [output-port (standard-output-port)] + [output-port (open-file-output-port "~/scheme-langserver.out" (file-options replace) 'none)] + [server-instance (init-server input-port output-port log-port #f #f)]) + (test-equal #f (server-shutdown? server-instance)) + ) +(test-end) + +(exit (if (zero? (test-runner-fail-count (test-runner-get))) 0 1)) diff --git a/tests/resources/did-create.json b/tests/resources/did-create.json new file mode 100644 index 00000000..2b24d0c1 --- /dev/null +++ b/tests/resources/did-create.json @@ -0,0 +1,6 @@ +{"jsonrpc":"2.0", + "method":"workspace/didCreateFiles", + "params":{ + "files":[{ + "uri":"file://~a/util/io.sls" + }]}} diff --git a/tests/resources/did-delete.json b/tests/resources/did-delete.json new file mode 100644 index 00000000..c5a48ab5 --- /dev/null +++ b/tests/resources/did-delete.json @@ -0,0 +1,5 @@ +{"jsonrpc":"2.0", + "method":"workspace/didDeleteFiles", + "params":{"files":[{ + "uri":"file://~a/util/io.sls" + }]}} From ab4a045a9003977bed4a8586a9c16e976d4ad509 Mon Sep 17 00:00:00 2001 From: VSteveHL Date: Mon, 14 Jul 2025 22:00:48 +0800 Subject: [PATCH 2/3] Test if the release works correctly. --- .github/workflows/release.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/release.yaml b/.github/workflows/release.yaml index d2a887c2..46dd7d92 100644 --- a/.github/workflows/release.yaml +++ b/.github/workflows/release.yaml @@ -1,4 +1,4 @@ -# stub from https://github.com/softprops/action-gh-release +# stub from https://github.com/softprops/action-gh-release name: Release on: push: From 9e65bdbc1c7bd65f5c2fca153713a4dddd0560a2 Mon Sep 17 00:00:00 2001 From: VSteveHL Date: Mon, 14 Jul 2025 22:08:50 +0800 Subject: [PATCH 3/3] Commented out PR triggers and musl build. --- .github/workflows/release.yaml | 33 +++++++++++++++------------------ 1 file changed, 15 insertions(+), 18 deletions(-) diff --git a/.github/workflows/release.yaml b/.github/workflows/release.yaml index 46dd7d92..3c52675a 100644 --- a/.github/workflows/release.yaml +++ b/.github/workflows/release.yaml @@ -4,8 +4,8 @@ on: push: tags: - "*.*.*" - pull_request: - branches: main + # pull_request: + # branches: main jobs: build-and-release: @@ -18,8 +18,8 @@ jobs: - name: Build Linux glibc image run: docker build . - - name: Build Linux musl image - run: docker build -f Dockerfile.musl . + # - name: Build Linux musl image + # run: docker build -f Dockerfile.musl . - name: Compile executable on Linux glibc run: | @@ -32,22 +32,19 @@ jobs: mv run build/scheme-langserver-x86_64-linux-glibc || exit 1 ' - - name: Compile executable on Linux musl - run: | - mkdir -p build - docker run \ - -v ./build:/root/scheme-langserver/build/ \ - $(docker build -f Dockerfile.musl -q .) \ - ash -c 'source .akku/bin/activate - compile-chez-program run.ss --static - mv run build/scheme-langserver-x86_64-linux-musl || exit 1 - ' + # - name: Compile executable on Linux musl + # run: | + # mkdir -p build + # docker run \ + # -v ./build:/root/scheme-langserver/build/ \ + # $(docker build -f Dockerfile.musl -q .) \ + # ash -c 'source .akku/bin/activate + # compile-chez-program run.ss --static + # mv run build/scheme-langserver-x86_64-linux-musl || exit 1 + # ' - name: Release uses: softprops/action-gh-release@v2 with: repo: ufo5260987423/scheme-langserver - files: | - build/scheme-langserver-x86_64-linux-glibc - build/scheme-langserver-x86_64-linux-musl - + files: build/scheme-langserver-x86_64-linux-glibc