Skip to content

Modify run.ss and scheme-langserver.sls #26

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
ufo5260987423 merged 4 commits into from
Aug 13, 2025
Merged

Modify run.ss and scheme-langserver.sls #26

Show file tree
Hide file tree
Changes from 1 commit
Commits
Show all changes
4 commits
Select commit Hold shift + click to select a range
94851d6
modify logic of run.ss
VSteveHL Aug 8, 2025
9abacfd
change identifier to 'akku
VSteveHL Aug 11, 2025
fe085aa
modify true/false to enable/disable
VSteveHL Aug 11, 2025
ba6c0cd
Commented out s7 and goldfish as they are not implemented yet
VSteveHL Aug 11, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
47 changes: 33 additions & 14 deletions protocol/server.sls
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -18,6 +18,7 @@
;close
server-condition
server-request-queue
server-top-environment

server-work-done-progress?
server-work-done-progress?-set!)
Expand All @@ -37,22 +38,40 @@
(mutable workspace)
(mutable shutdown?)
(mutable condition)
(mutable work-done-progress?))
(mutable work-done-progress?)
(immutable top-environment)
)
(protocol
(lambda (new)
(lambda (input-port output-port log-port thread-pool request-queue workspace type-inference?)
(new
input-port
output-port
log-port
thread-pool
(if (null? thread-pool) '() (make-mutex))
request-queue
type-inference?
workspace
#f
(make-condition)
#f)))))
(case-lambda
[(input-port output-port log-port thread-pool request-queue workspace type-inference?)
(new
input-port
output-port
log-port
thread-pool
(if (null? thread-pool) '() (make-mutex))
request-queue
type-inference?
workspace
#f
(make-condition)
#f
'r6rs)]
[(input-port output-port log-port thread-pool request-queue workspace type-inference? top-environment)
(new
input-port
output-port
log-port
thread-pool
(if (null? thread-pool) '() (make-mutex))
request-queue
type-inference?
workspace
#f
(make-condition)
#f
top-environment)]))))

(define (do-log message server-instance)
(if (not (null? (server-log-port server-instance)))
Expand Down
111 changes: 90 additions & 21 deletions run.ss
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -6,33 +6,92 @@
(define (display-help)
(let ([prog-name (car (command-line))])
(format (current-error-port) "Usage:
~a --help | -h
~a [input-port] [output-port] [log-path]

~a [option] ...

Options:
-l, --log-path Path to write log output (default: current-project-directory/.scheme-langserver.log)
-m, --multi-thread Enable multi thread (default: enable). use f or false to diasble

-t, --type-inference Enable type inference (default: enable). use f or false to diasble


-h, --help Print help information

-e, --top-environment Switch to support different top environment, for example R6RS, R7RS, etc.(default: R6RS)

Arguments:
input-port Port to read messages (default: stdin)
output-port Port to write messages (default: stdout)
log-path Path to write log output (default: null)

Example Usage:
~a /path/to/scheme-langserver.log\n"
prog-name prog-name prog-name)))
~a -l /path/to/scheme-langserver.log\n"
prog-name prog-name)))

(define default-log-path "./.scheme-langserver.log")
(define default-multi-thread #t)
(define default-type-inference #t)
(define default-top-environment "R6RS")

(define (make-default-options)
(let ((ht (make-hashtable string-hash equal?)))
(hashtable-set! ht "log-path" default-log-path)
(hashtable-set! ht "multi-thread" default-multi-thread)
(hashtable-set! ht "type-inference" default-type-inference)
(hashtable-set! ht "top-environment" default-top-environment)
ht))

(define (log-path-proc option name arg seeds)
(hashtable-set! seeds "log-path" arg)
seeds)

(define (multi-thread-proc option name arg seeds)
(cond
((or (string-ci=? arg "t") (string-ci=? arg "true"))
(hashtable-set! seeds "multi-thread" #t))
((or (string-ci=? arg "f") (string-ci=? arg "false"))
(hashtable-set! seeds "multi-thread" #f)))
seeds)

(define (type-inference-proc option name arg seeds)
(cond
((or (string-ci=? arg "t") (string-ci=? arg "true"))
(hashtable-set! seeds "type-inference" #t))
((or (string-ci=? arg "f") (string-ci=? arg "false"))
(hashtable-set! seeds "type-inference" #f)))
seeds)

(define (top-environment-parse str)
(cond
((string-ci=? str "r6rs") 'r6rs)
((string-ci=? str "r7rs") 'r7rs)
((string-ci=? str "s7") 's7)
Copy link
Copy Markdown
Collaborator

@ufo5260987423 ufo5260987423 Aug 11, 2025

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Should these two line in comment? Because now they haven't been supposed now. And they only should been uncommented when coressponding top environment be supposed.

Copy link
Copy Markdown
Collaborator

@ufo5260987423 ufo5260987423 Aug 11, 2025

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I mean s7 and goldfish

((string-ci=? str "goldfish") 'goldfish)
(else #f)))


(define (top-environment-proc option name arg seeds)
(let ((val (top-environment-parse arg)))
(if val
(begin
(hashtable-set! seeds "top-environment" val)
seeds)
(begin
(display "Invalid value for --top-environment. Valid values: r6rs, r7rs, s7, goldfish\n")
(exit 1)))))

(define options
(list
(option '(#\h "help") #f #f
(lambda (opt name arg seeds)
(display-help)
(exit 0)))
;; (option '("multi-thread") #f #f
;; (lambda (opt name arg seeds)
;; (scheme-lsp-args-multi-thread-set! seeds #t)
;; seeds))
;; (option '("type-inference") #f #f
;; (lambda (opt name arg seeds)
;; (scheme-lsp-args-type-inference-set! seeds #t)
;; seeds))
))
(option '(#\l "log-path") #t #f
log-path-proc)
(option '(#\m "multi-thread") #t #f
multi-thread-proc)
(option '(#\t "type-inference") #t #f
type-inference-proc)
(option '(#\e "top-environment") #t #f
top-environment-proc)
))

(let* ([args (args-fold
(command-line-arguments)
Expand All @@ -42,8 +101,18 @@ Example Usage:
(display-help)
(exit 0))
(lambda (operand seeds)
(cons operand seeds))
'())]
[operands (reverse args)])
seeds)
(make-default-options))])
;; TODO: use options
(apply init-server operands))
;; (apply init-server operands)
(init-server
(standard-input-port)
(standard-output-port)
(open-file-output-port
(hashtable-ref args "log-path" default-log-path)
(file-options replace)
'block
(make-transcoder (utf-8-codec))) ;; log port
(hashtable-ref args "multi-thread" default-multi-thread)
(hashtable-ref args "type-inference" default-type-inference)
(hashtable-ref args "top-environment" default-top-environment)))
23 changes: 15 additions & 8 deletions scheme-langserver.sls
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -125,6 +125,7 @@
[client-capabilities (assq-ref params 'capabilities)]
[window (assq-ref client-capabilities 'window)]
[workDoneProgress? (if window (assq-ref window 'workDoneProgress) #f)]
[identifier (if (equal? (server-top-environment server-instance) 'r6rs) 'akku 'txt)]
Comment thread
ufo5260987423 marked this conversation as resolved.
Outdated
[textDocument (assq-ref params 'textDocument)]
; [renameProvider
; (if (assq-ref (assq-ref (assq-ref params 'textDocumet) 'rename) 'prepareSupport)
Expand Down Expand Up @@ -174,13 +175,13 @@

(if (null? (server-mutex server-instance))
(begin
(server-workspace-set! server-instance (init-workspace root-path #f (server-type-inference? server-instance)))
(server-workspace-set! server-instance (init-workspace root-path identifier (server-top-environment server-instance) #f (server-type-inference? server-instance)))
(server-work-done-progress?-set! server-instance workDoneProgress?)
(success-response id (make-alist 'capabilities server-capabilities)))
(with-mutex (server-mutex server-instance)
(if (null? (server-workspace server-instance))
(begin
(server-workspace-set! server-instance (init-workspace root-path #t (server-type-inference? server-instance)))
(server-workspace-set! server-instance (init-workspace root-path identifier (server-top-environment server-instance) #t (server-type-inference? server-instance)))
(server-work-done-progress?-set! server-instance workDoneProgress?)
(success-response id (make-alist 'capabilities server-capabilities)))
(fail-response id server-error-start "server has been initialized"))))))
Expand All @@ -193,7 +194,8 @@
(standard-output-port)
'()
#f
#f)]
#f
'r6rs)]
[(log-path)
(init-server
(standard-input-port)
Expand All @@ -204,10 +206,11 @@
'block
(make-transcoder (utf-8-codec)))
#f
#f)]
#f
'r6rs)]
[(log-path enable-multi-thread?)
(init-server log-path enable-multi-thread? #f)]
[(log-path enable-multi-thread? type-inference?)
[(log-path enable-multi-thread? type-inference?)
(init-server
(standard-input-port)
(standard-output-port)
Expand All @@ -217,14 +220,17 @@
'block
(make-transcoder (utf-8-codec)))
(equal? enable-multi-thread? "enable")
(equal? type-inference? "enable"))]
(equal? type-inference? "enable")
'r6rs)]
[(input-port output-port log-port enable-multi-thread?)
(init-server input-port output-port log-port enable-multi-thread? #f)]
(init-server input-port output-port log-port enable-multi-thread? #f 'r6rs)]
[(input-port output-port log-port enable-multi-thread? type-inference?)
(init-server input-port output-port log-port enable-multi-thread? type-inference? 'r6rs)]
[(input-port output-port log-port enable-multi-thread? type-inference? top-environment)
;The thread-pool size just limits how many threads to process requests;
(let* ([thread-pool (if (and enable-multi-thread? threaded?) (init-thread-pool 1 #t) '())]
[request-queue (if (and enable-multi-thread? threaded?) (make-request-queue) '())]
[server-instance (make-server input-port output-port log-port thread-pool request-queue '() type-inference?)]
[server-instance (make-server input-port output-port log-port thread-pool request-queue '() type-inference? top-environment)]
[request-processor (lambda (r) (private:try-catch server-instance r))])
(try
(if (not (null? thread-pool))
Expand All @@ -247,4 +253,5 @@
[else
(display-condition c log-port)
(do-log-timestamp server-instance)])))]))

)
2 changes: 1 addition & 1 deletion tests/analysis/test-tokenizer.sps
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -13,7 +13,7 @@
(scheme-langserver analysis tokenizer))

(test-begin "read ss")
(test-equal 4 (length (source-file->annotations "./run.ss")))
(test-equal 14 (length (source-file->annotations "./run.ss")))
(test-end)

(test-begin "read sps")
Expand Down