Opencode-Racket-LSP/opencode-racket-lsp.rkt at main · RickyYCheng/Opencode-Racket-LSP · 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
#lang racket/base

(require json
         mzlib/cml
         racket/exn
         racket/function
         racket/list
         racket/match
         racket/class
         racket/string
         racket/async-channel
         racket-langserver/common/interfaces
         racket-langserver/common/debug
         racket-langserver/lsp/methods
         racket-langserver/lsp/msg-io
         racket-langserver/lsp/responses)

(struct Q (in-ch out-ch mgr-t))

(define (queue)
  (define in-ch (channel))
  (define out-ch (channel))
  (define (serve ready-req-evts)
    (cond [(empty? ready-req-evts)
           (serve (list (sync (channel-recv-evt in-ch))))]
          [else
           (sync (choice-evt
                   (wrap-evt (channel-recv-evt in-ch)
                             (λ (m)
                               (serve (append ready-req-evts (list m)))))
                   (wrap-evt (channel-send-evt out-ch (first ready-req-evts))
                             (thunk*
                              (serve (rest ready-req-evts))))))]))
  (define mgr-t (spawn (λ () (serve empty))))
  (Q in-ch out-ch mgr-t))

(define (queue-send-evt q v)
  (guard-evt
   (λ ()
     (thread-resume (Q-mgr-t q) (current-thread))
     (channel-send-evt (Q-in-ch q) v))))

(define (queue-recv-evt q)
  (guard-evt
   (λ ()
     (thread-resume (Q-mgr-t q) (current-thread))
     (channel-recv-evt (Q-out-ch q)))))

(define (report-error exn)
  (eprintf "\nCaught exn:\n~a\n" (exn->string exn)))

(define fixed-server%
  (class server%
    (super-new)
    (define/override (handle-request id method params)
      (cond
        [(and (equal? method "initialize") (hash? params) (not (hash-has-key? params 'rootPath)))
         (define root-uri (hash-ref params 'rootUri #f))
         (define root-path
           (if (and (string? root-uri) (string-prefix? root-uri "file://"))
               (substring root-uri 7)
               (current-directory)))
         (super handle-request id method (hash-set params 'rootPath root-path))]
        [else
         (super handle-request id method params)]))))

(define (main-loop)
  (define resp-ch (make-async-channel))
  (define server (new fixed-server%
                     [response-channel resp-ch]
                     [request-channel resp-ch]
                     [notification-channel resp-ch]))
  (define q (queue))
  (define (consume)
    (define msg (sync (queue-recv-evt q)))
    (match msg
      ['parse-json-error
       (define err "Invalid JSON was received by the server.")
       (display-message/flush (error-response (json-null) ErrorCode-ParseError err))]
      [_
       (maybe-debug-log msg)
       (with-handlers ([exn:fail? report-error])
         (send server process-message msg))])
    (consume))
  (define (write-resp)
    (display-message/flush (async-channel-get resp-ch))
    (write-resp))
  (spawn consume)
  (spawn write-resp)
  (for ([msg (in-port read-message)])
    (sync (queue-send-evt q msg)))
  (eprintf "Unexpected EOF\n")
  (exit 1))

(module+ main
  (main-loop))