scheme-langserver/run.ss at main · MoganLab/scheme-langserver · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
(import
    (chezscheme)
    (srfi :37 args-fold)
    (scheme-langserver))

(define (display-help)
  (let ([prog-name (car (command-line))])
    (format (current-error-port) "Usage:

  ~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)

  -t, --type-inference          Enable type inference. (default: enable)

  -c, --cache-path              Directory to read/write workspace FASL cache. (default: disabled)

  -h, --help                    Print help information.

  -v, --version                 Print version information.

  -e, --top-environment         Switch between different top environments, for example R6RS, R7RS, s7, goldfish, etc.(default: R6RS)


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

(define (private:get-version)
  (or
    (guard (e [else #f])
      (let-values ([(to-stdin from-stdout from-stderr pid)
                    (open-process-ports "git describe --tags --always --dirty 2>/dev/null"
                                        (buffer-mode block)
                                        (native-transcoder))])
        (let ([line (get-line from-stdout)])
          (close-output-port to-stdin)
          (close-input-port from-stdout)
          (close-input-port from-stderr)
          (if (or (eof-object? line) (string=? line ""))
            #f
            line))))
    (guard (e [else #f])
      (call-with-input-file ".version"
        (lambda (p)
          (let ([line (get-line p)])
            (if (eof-object? line) #f line)))))
    "2.1.3"))

(define version (private:get-version))

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

(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)
    (hashtable-set! ht "cache-path" default-cache-path)
    ht))

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

(define (boolean-option-proc key)
  (lambda (option name arg seeds)
    (cond
      [(string-ci=? arg "enable")
        (hashtable-set! seeds key #t)]
      [(string-ci=? arg "disable")
        (hashtable-set! seeds key #f)])
    seeds))

(define multi-thread-proc (boolean-option-proc "multi-thread"))
(define type-inference-proc (boolean-option-proc "type-inference"))

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

(define (top-environment-parse str)
  (cond
    ((string-ci=? str "r6rs") 'r6rs)
    ((string-ci=? str "r7rs") 'r7rs)
    ((string-ci=? str "s7") 's7)
    ((string-ci=? str "goldfish") 's7)
    (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\n")
        (exit 1)))))

(define options
  (list
   (option '(#\h "help") #f #f
           (lambda (opt name arg seeds)
             (display-help)
             (exit 0)))
   (option '(#\v "version") #f #f
           (lambda (opt name arg seeds)
             (format (current-output-port) "scheme-langserver ~a\n" version)
             (exit 0)))
    (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)
    (option '(#\c "cache-path") #t #f
           cache-path-proc)))

(let* ([args
        (args-fold
          (command-line-arguments)
          options
          (lambda (opt name arg seeds)
            (format (current-error-port) "Unrecognized option: ~a\n" name)
            (display-help)
            (exit 1))
          (lambda (operand seeds)
            seeds)
          (make-default-options))])
  (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)))
    (hashtable-ref args "multi-thread" default-multi-thread)
    (hashtable-ref args "type-inference" default-type-inference)
    (hashtable-ref args "top-environment" default-top-environment)
    #f
    (hashtable-ref args "cache-path" default-cache-path)))