From b2ecaa54d8a0b68273d19df57e878e015142ea84 Mon Sep 17 00:00:00 2001 From: VSteveHL Date: Wed, 9 Jul 2025 22:28:33 +0800 Subject: [PATCH 1/4] sync from xmain --- analysis/package-manager/txt-filter.sls | 7 ++----- analysis/workspace.sls | 15 +++++++-------- 2 files changed, 9 insertions(+), 13 deletions(-) diff --git a/analysis/package-manager/txt-filter.sls b/analysis/package-manager/txt-filter.sls index 96bc88e8..45ffdff2 100644 --- a/analysis/package-manager/txt-filter.sls +++ b/analysis/package-manager/txt-filter.sls @@ -4,14 +4,11 @@ (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] [else #f]))) ) \ No newline at end of file diff --git a/analysis/workspace.sls b/analysis/workspace.sls index f76f2a26..65710f42 100644 --- a/analysis/workspace.sls +++ b/analysis/workspace.sls @@ -85,18 +85,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 From 35b7ee76e542210f322d0ed08131b5d57df219d9 Mon Sep 17 00:00:00 2001 From: VSteveHL Date: Wed, 9 Jul 2025 23:03:26 +0800 Subject: [PATCH 2/4] feat: Add top-environment parameter to the workspace type - Added (immutable top-environment) to define-record-type workspace - Modified the refresh-workspace function to determine which filter to use based on top-environment --- analysis/workspace.sls | 13 ++++++++++--- tests/analysis/test-workspace.sps | 11 +++++------ 2 files changed, 15 insertions(+), 9 deletions(-) diff --git a/analysis/workspace.sls b/analysis/workspace.sls index 65710f42..3e8cd330 100644 --- a/analysis/workspace.sls +++ b/analysis/workspace.sls @@ -63,11 +63,18 @@ (immutable facet) ;only for identifer catching and type inference (immutable threaded?) - (immutable type-inference?))) + (immutable type-inference?) + (immutable top-environment))) (define (refresh-workspace workspace-instance) (let* ([path (file-node-path (workspace-file-node workspace-instance))] - [root-file-node (init-virtual-file-system path '() (generate-akku-acceptable-file-filter (string-append path "/.akku/list")))] + [top-environment (workspace-top-environment workspace-instance)] + [filter + (case top-environment + ['r6rs (generate-akku-acceptable-file-filter (string-append path "/.akku/list"))] + ['r7rs (generate-txt-file-filter)] + [else (generate-akku-acceptable-file-filter (string-append path "/.akku/list"))])] + [root-file-node (init-virtual-file-system path '() filter)] [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)]) @@ -95,7 +102,7 @@ [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 facet threaded? type-inference?))])) + (make-workspace root-file-node root-library-node file-linkage facet threaded? type-inference? top-environment))])) ;; head -[linkage]->files ;; for single file 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)) From f725b97a32be7631fbf7a119916da457af3080c9 Mon Sep 17 00:00:00 2001 From: VSteveHL Date: Thu, 10 Jul 2025 20:04:06 +0800 Subject: [PATCH 3/4] I think that txt-filter.sls still need `[(file-directory? path) #t]` --- analysis/package-manager/txt-filter.sls | 1 + analysis/workspace.sls | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/analysis/package-manager/txt-filter.sls b/analysis/package-manager/txt-filter.sls index 45ffdff2..6b5091b8 100644 --- a/analysis/package-manager/txt-filter.sls +++ b/analysis/package-manager/txt-filter.sls @@ -10,5 +10,6 @@ (lambda (path) (cond [(string-suffix? ".scm.txt" path) #t] + [(file-directory? path) #t] [else #f]))) ) \ No newline at end of file diff --git a/analysis/workspace.sls b/analysis/workspace.sls index 3e8cd330..5b7f0511 100644 --- a/analysis/workspace.sls +++ b/analysis/workspace.sls @@ -91,7 +91,7 @@ [(path threaded? type-inference?) (init-workspace path 'akku 'r6rs threaded? type-inference?)] [(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)) + ;;(pretty-print `(DEBUG: function init-workspace :: ,@(list path identifier top-environment threaded? type-inference?))) (let* ([facet (case identifier [txt (generate-txt-file-filter)] From 6a26f862d77c1a5fe686f7c318171831b4cb686d Mon Sep 17 00:00:00 2001 From: VSteveHL Date: Tue, 15 Jul 2025 00:53:40 +0800 Subject: [PATCH 4/4] use case-lambda rewrite init-document, init-virtual-file-system and attach-new-file --- analysis/workspace.sls | 133 +++++++++++++++++++++-------------------- 1 file changed, 69 insertions(+), 64 deletions(-) diff --git a/analysis/workspace.sls b/analysis/workspace.sls index 9b9b2640..fb358c80 100644 --- a/analysis/workspace.sls +++ b/analysis/workspace.sls @@ -17,6 +17,7 @@ workspace-file-linkage workspace-facet workspace-type-inference? + workspace-top-environment update-file-node-with-tail @@ -72,13 +73,7 @@ (define (refresh-workspace workspace-instance) (let* ([path (file-node-path (workspace-file-node workspace-instance))] - [top-environment (workspace-top-environment workspace-instance)] - [filter - (case top-environment - ['r6rs (generate-akku-acceptable-file-filter (string-append path "/.akku/list"))] - ['r7rs (generate-txt-file-filter)] - [else (generate-akku-acceptable-file-filter (string-append path "/.akku/list"))])] - [root-file-node (init-virtual-file-system path '() filter)] + [root-file-node (init-virtual-file-system path '() (workspace-facet workspace-instance) (workspace-top-environment workspace-instance))] [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)]) @@ -101,7 +96,7 @@ [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-file-node (init-virtual-file-system path '() facet top-environment)] [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)]) @@ -226,31 +221,35 @@ [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) - (let* ([name (path->name path)] - [folder? (file-directory? path)] - [document - (if folder? - '() - (init-document path))] - [node (make-file-node path name parent folder? '() document)] - [children (if folder? - (map - (lambda (p) - (init-virtual-file-system - (string-append path - (if (string-suffix? (string (directory-separator)) path) - "" - (string (directory-separator))) - p) - node - my-filter)) - (directory-list path)) - '())]) - (file-node-children-set! node (filter (lambda (p) (not (null? p))) children)) - node) - '())) +(define init-virtual-file-system + (case-lambda + [(path parent my-filter) (init-virtual-file-system path parent my-filter 'r6rs)] + [(path parent my-filter top-environment) + (if (my-filter path) + (let* ([name (path->name path)] + [folder? (file-directory? path)] + [document + (if folder? + '() + (init-document path top-environment))] + [node (make-file-node path name parent folder? '() document)] + [children (if folder? + (map + (lambda (p) + (init-virtual-file-system + (string-append path + (if (string-suffix? (string (directory-separator)) path) + "" + (string (directory-separator))) + p) + node + my-filter + top-environment)) + (directory-list path)) + '())]) + (file-node-children-set! node (filter (lambda (p) (not (null? p))) children)) + node) + '())])) (define (remove-new-file path parent my-filter) @@ -264,37 +263,43 @@ (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 attach-new-file + (case-lambda + [(path parent my-filter) (attach-new-file path parent my-filter 'r6rs)] + [(path parent my-filter top-environment) + (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 top-environment) + (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 top-environment)]) + (file-node-children-set! parent `(,@(file-node-children parent) ,new-node)) + new-node)))] + [else + (let* ([name (path->name path)] + [document (init-document path top-environment)] + [node (make-file-node path name parent #f '() document)]) + (file-node-children-set! parent `(,@(file-node-children parent) ,node)) + node)]))])) -(define (init-document path) +(define (init-document path top-environment) (let ([uri (path->uri path)] - [s (read-string path)]) + [s (read-string path)] + [meta-lib (case top-environment + ['r7rs '(scheme base)] + [else '(chezscheme)])]) (try (cond [(string? s) @@ -302,13 +307,13 @@ uri s (map (lambda (item) (init-index-node '() item)) (source-file->annotations path)) - (find-meta '(chezscheme)))] + (find-meta meta-lib top-environment))] [(eof-object? s) (make-document uri "" '() - (find-meta '(chezscheme)))] + (find-meta meta-lib top-environment))] [else '()]) (except c [(equal? c 'can-not-tolerant) '()]