Extract server concept from current complicated msg-io interaction

check-syntax.rkt

@@ -7,14 +7,16 @@
          racket/logging
          racket/list
          racket/string
+         racket/port
          syntax/modread
          racket/sandbox
          setup/path-to-relative
+         json
          "editor.rkt"
          "responses.rkt"
+         "server.rkt"
          "interfaces.rkt"
          "doc-trace.rkt"
-         "msg-io.rkt"
          "responses.rkt"
          "scheduler.rkt"
          "path-util.rkt")
@@ -132,16 +134,17 @@
      ; check for a #reader directive at start of file, ignoring comments
      ; the ^ anchor here matches start-of-string, not start-of-line
      (if (regexp-match #rx"^(;[^\n]*\n)*#reader" text)
-       #f ; most likely a drracket file, use default indentation
-          ; (https://github.com/jeapostrophe/racket-langserver/issues/86)
-       'missing)]
+         #f ; most likely a drracket file, use default indentation
+         ; (https://github.com/jeapostrophe/racket-langserver/issues/86)
+         'missing)]
     [else #f]))
 
 (define-syntax-rule (timeout time-sec body)
   (with-limits time-sec #f body))
 
-(define (send-diagnostics uri diag-lst)
-  (display-message/flush (diagnostics-message uri diag-lst)))
+(define (send-diagnostics-notification uri diag-lst)
+  (send current-server flush-message
+        (diagnostics-message uri diag-lst)))
 
 (define (check-syntax uri doc-text)
   (define src (uri->path uri))
@@ -170,9 +173,9 @@
                    [current-namespace ns]
                    [current-load-relative-directory src-dir])
       (with-intercepted-logging
-        (lambda (l)
-          (define result (check-typed-racket-log doc-text l))
-          (when (list? result) (set! diags (append result diags))))
+          (lambda (l)
+            (define result (check-typed-racket-log doc-text l))
+            (when (list? result) (set! diags (append result diags))))
         (lambda ()
           (with-handlers ([(or/c exn:fail:read?
                                  exn:fail:syntax?
@@ -196,21 +199,21 @@
 
   (define warn-diags (set->list (send new-trace get-warn-diags)))
   (define other-diags (append err-diags lang-diag diags))
-  (send-diagnostics uri (append warn-diags other-diags))
+  (send-diagnostics-notification uri (append warn-diags other-diags))
 
   (define (task)
     (send new-trace walk-text text)
     (define new-warn-diags (set->list (send new-trace get-warn-diags)))
     ;; send a diagnostics to force client send a new code action request
-    (when (not (equal? new-warn-diags warn-diags))
-      (send-diagnostics uri (append new-warn-diags other-diags))))
+    (unless (equal? new-warn-diags warn-diags)
+      (send-diagnostics-notification uri (append new-warn-diags other-diags))))
   (when valid
     (scheduler-push-task! uri 'walk-text task))
 
   (if valid new-trace #f))
 
 (provide
-  (contract-out
-    [check-syntax (-> any/c (is-a?/c lsp-editor%)
-                      (or/c #f (is-a?/c build-trace%)))]))
+ (contract-out
+  [check-syntax (-> any/c (is-a?/c lsp-editor%)
+                    (or/c #f (is-a?/c build-trace%)))]))
 

info.rkt

@@ -15,6 +15,6 @@
                "racket-index" ;; for cross references (setup/xref)
                "html-parsing" ;; for parsing documentation text
                ))
-(define build-deps '("chk-lib"))
+(define build-deps '("chk-lib" "rackunit-lib"))
 (define pkg-desc "Language Server Protocol implementation for Racket.")
 (define version "1.0")

main.rkt

@@ -5,10 +5,13 @@
          racket/function
          racket/list
          racket/match
+         racket/class
+         racket/async-channel
          "debug.rkt"
          "error-codes.rkt"
          "methods.rkt"
          "msg-io.rkt"
+         "server.rkt"
          "responses.rkt")
 
 ;; https://www.cs.utah.edu/plt/publications/pldi04-ff.pdf
@@ -56,6 +59,9 @@
 ;; * out-t          - defined in `msg-io.rkt`, put the response message
 ;;                    to a specified output-port or current-output-port.
 (define (main-loop)
+  (define resp-ch (make-async-channel))
+  (set-current-server! (new server% [output-channel resp-ch]))
+
   (define q (queue))
   (define (consume)
     (define msg (sync (queue-recv-evt q)))
@@ -66,10 +72,14 @@
       [_
        (maybe-debug-log msg)
        (with-handlers ([exn:fail? report-error])
-         (process-message msg))])
+         (send current-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")

methods.rkt

@@ -4,11 +4,11 @@
          racket/contract/base
          racket/exn
          racket/match
+         racket/class
+         racket/async-channel
          "error-codes.rkt"
-         "msg-io.rkt"
          "responses.rkt"
          "struct.rkt"
-         "server-request.rkt"
          (prefix-in workspace/ "workspace.rkt")
          (prefix-in text-document/ "text-document.rkt"))
 
@@ -55,43 +55,71 @@
 ;; Dispatch
 ;;;;;;;;;;;;;
 
-;; Processes a message. This displays any repsonse it generates
-;; and should always return void.
-(define (process-message msg)
-  (match msg
-    ;; Request
-    [(hash-table ['id (? (or/c number? string?) id)]
-                 ['method (? string? method)])
-     (define params (hash-ref msg 'params hasheq))
-     (define response (process-request id method params))
-     ;; the result can be a response or a procedure which returns
-     ;; a response. If it's a procedure, then it's expected to run
-     ;; concurrently.
-     (thread (λ ()
-               (display-message/flush
-                 (if (procedure? response)
-                     (response)
-                     response))))
-     (void)]
-    ;; Notification
-    [(hash-table ['method (? string? method)])
-     (define params (hash-ref msg 'params hasheq))
-     (process-notification method params)]
-    [(hash-table ['jsonrpc "2.0"]
-                 ['id id]
-                 ['result result])
-     (define handler (hash-ref response-handlers id))
-     (handler result)
-     (hash-remove! response-handlers id)]
-    ;; Batch Request
-    [(? (non-empty-listof (and/c hash? jsexpr?)))
-     (for-each process-message msg)]
-    ;; Invalid Message
-    [_
-     (define id-ref (hash-ref msg 'id void))
-     (define id (if ((or/c number? string?) id-ref) id-ref (json-null)))
-     (define err "The JSON sent is not a valid request object.")
-     (display-message/flush (error-response id INVALID-REQUEST err))]))
+(define server%
+  (class object%
+    (super-new)
+
+    (init-field output-channel)
+    (field
+     ; Each request sent by server should register its response handler here
+     [response-handlers (make-hash)])
+
+    (define/public (flush-message msg)
+      (async-channel-put output-channel msg))
+
+    (define/public (send-request id method params handler)
+      ; register handler
+      (hash-set! response-handlers id handler)
+      ; send request to LSP client
+      (flush-message (hasheq 'id id
+                             'method method
+                             'params params)))
+
+    ;; Processes a message (a JSON). This displays any repsonse it generates
+    ;; and should always return void.
+    (define/public (process-message msg)
+      (match msg
+        ;; Request
+        [(hash-table ['id (? (or/c number? string?) id)]
+                     ['method (? string? method)])
+         (define params (hash-ref msg 'params hasheq))
+         (define response (handle-request id method params))
+         ;; the result can be a response or a procedure which returns
+         ;; a response. If it's a procedure, then it's expected to run
+         ;; concurrently.
+         (thread (λ ()
+                   (flush-message
+                    (if (procedure? response)
+                        (response)
+                        response))))
+         (void)]
+        ;; Notification
+        [(hash-table ['method (? string? method)])
+         (define params (hash-ref msg 'params hasheq))
+         (handle-notification method params)]
+        ;; Response
+        [(hash-table ['jsonrpc "2.0"]
+                     ['id id]
+                     ['result result])
+         (define handler (hash-ref response-handlers id))
+         (handler result)
+         (hash-remove! response-handlers id)]
+        ;; Batch Request
+        [(? (non-empty-listof (and/c hash? jsexpr?)))
+         (for-each (lambda (msg) (process-message msg)) msg)]
+        ;; Invalid Message
+        [_
+         (define id-ref (hash-ref msg 'id void))
+         (define id (if ((or/c number? string?) id-ref) id-ref (json-null)))
+         (define err "The JSON sent is not a valid request object.")
+         (flush-message (error-response id INVALID-REQUEST err))]))
+
+    (define/public (handle-request id method params)
+      (process-request id method params))
+
+    (define/public (handle-notification method params)
+      (process-notification method params))
+    ))
 
 (define ((report-request-error id method) exn)
   (eprintf "Caught exn in request ~v\n~a\n" method (exn->string exn))
@@ -211,10 +239,10 @@
                'workspace
                (hasheq 'fileOperations
                        (hasheq 'didRename ; workspace.fileOperations.didRename
-                                (hasheq 'filters
-                                        (map (lambda (ext)
-                                                (hasheq 'scheme "file" 'pattern (hasheq 'glob (format "**/*.~a" ext))))
-                                              (get-module-suffixes))))
+                               (hasheq 'filters
+                                       (map (lambda (ext)
+                                              (hasheq 'scheme "file" 'pattern (hasheq 'glob (format "**/*.~a" ext))))
+                                            (get-module-suffixes))))
                        'workspaceFolders (hasheq 'changeNotifications #t))))
 
      (define resp (success-response id (hasheq 'capabilities server-capabilities)))
@@ -229,8 +257,4 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(provide
-  (contract-out
-    [process-message
-     (jsexpr? . -> . void?)]))
-
+(provide server%)

server.rkt

@@ -0,0 +1,7 @@
+#lang racket/base
+(provide current-server
+         set-current-server!)
+
+(define current-server #f)
+(define (set-current-server! s)
+  (set! current-server s))