omnibus cleanup of first version of lsp

- provide default implementation of jzon-value
- improve naming of message key and path accessors
- conditionalize worker error debugging
!- add document-changed notification

resources/fib.coal

@@ -2,7 +2,7 @@
   (import
     coalton-prelude)
   (export
-    fob))
+    fib))
 
 (declare fib (Integer -> Integer))
 (define (fib n)

src/lib/json.lisp

@@ -33,7 +33,9 @@
       (com.inuoe.jzon:write-value writer (com.inuoe.jzon:parse string)))))
 
 (defgeneric jzon-value (message-class value)
-  (:documentation "Convert a message to a value that can be directly serialized by jzon."))
+  (:documentation "Convert a message to a value that can be directly serialized by jzon.")
+  (:method (message-class value)
+    value))
 
 ;;; The values of atoms are all lisp atomic types that jzon serializes
 ;;; correctly.
@@ -44,9 +46,6 @@
         (t
          (error "non-atom value in atom field: check the field type? value: ~s" value))))
 
-(defmethod jzon-value ((self message-enum) value)
-  value)
-
 ;;; Construct a jzon value, considering the 'vector and 'optional
 ;;; properties of a field.
 

src/lib/message.lisp

@@ -57,16 +57,16 @@ The output value will have string-valued map keys.")
   (destructuring-bind (name type) spec
     (destructuring-bind (class optional vector) (parse-field-type type)
       (make-instance 'message-field
-        :name name
-        :json (camel-case name)
-        :class class
-        :optional optional
-        :vector vector))))
+                     :name name
+                     :json (camel-case name)
+                     :class class
+                     :optional optional
+                     :vector vector))))
 
 (defclass message-class (message-type)
   ((fields :initform (make-array 0 :adjustable t :fill-pointer t)
            :reader message-fields)))
-  
+
 (defmethod print-object ((self message-class) stream)
   (with-slots (name fields) self
     (print-unreadable-object (self stream :type t :identity t)
@@ -171,18 +171,18 @@ The output value will have string-valued map keys.")
                  :class (get-message-class class)
                  :value value))
 
-(defun field-1 (message key)            ; FIXME bad name
+(defun %get-key (message key)
   (let ((field (%get-field (message-class message) key)))
     (make-instance 'message
                    :class (message-class field)
                    :value (cdr (assoc (json-key field)
                                       (message-value message)
                                       :test #'string=)))))
 
-(defun field-n (message path)           ; FIXME bad name
-  (reduce #'field-1 (listify path) :initial-value message))
+(defun %get-path (message path)
+  (reduce #'%get-key (listify path) :initial-value message))
 
-(defun set-field-1 (message key value)
+(defun %set-key (message key value)
   (let ((field (%get-field (message-class message) key)))
     (make-message (name (message-class message))
                   (acons (json-key field)
@@ -192,20 +192,19 @@ The output value will have string-valued map keys.")
                                  :key #'car
                                  :test #'string=)))))
 
-(defun with-field (message path value)
+(defun %set-path (message path value)
   (destructuring-bind (key &rest keys) (listify path)
-    (set-field-1 message key
-                 (if (null keys)
-                     value
-                     (message-value (with-field (field-1 message key)
-                                      keys value))))))
+    (%set-key message key
+              (if (null keys)
+                  value
+                  (message-value (%set-path (%get-key message key) keys value))))))
 
 ;; Message API
 
 (defun get-field (message path)
-  (message-value (field-n message (listify path))))
+  (message-value (%get-path message (listify path))))
 
 (defun set-field (message path value)
   (setf (slot-value message 'value)
-        (slot-value (with-field message (listify path) value) 'value))
+        (slot-value (%set-path message (listify path) value) 'value))
   message)

src/lib/process.lisp

@@ -10,10 +10,10 @@
   (:method (process) "Coalton LSP Process"))
 
 (defgeneric run (process)
-  (:documentation "Run a process. This function is run by a newly started process. IF the function returns, the process will halt."))
+  (:documentation "The function run by a started process. The process halts when it returns."))
 
 (defgeneric stop (process)
-  (:documentation "Synchronously stop a process and immediately return."))
+  (:documentation "Synchronously stop a process."))
 
 (defclass process ()
   ((thread :initform nil)
@@ -32,8 +32,11 @@
 
 (defmethod stop ((self process))
   (with-slots (thread) self
-    (when thread
-      (bt:destroy-thread thread)
+    (when (and thread (bt:thread-alive-p thread))
+      (handler-case
+          (bt:destroy-thread thread)
+        (error (e)
+          (/warn "error during thread cleanup: ~a" e)))
       (setf thread nil)))
   self)
 
@@ -42,6 +45,8 @@
 (defvar *worker-poll-interval* 0.250
   "How long to sleep when there is no work to do.")
 
+(defvar *worker-debug* nil)
+
 (defclass worker (process)
   ((fn)
    (run :initform t
@@ -72,7 +77,8 @@
               (handler-case
                   (funcall (slot-value worker 'fn) element)
                 (condition (condition)
-                  (break)
+                  (when *worker-debug*
+                    (signal condition))
                   (/error "ignoring error : ~a" condition))))))
 
 (defmethod run ((self worker))
@@ -83,4 +89,4 @@
          (loop :while (run-p self)
                :do (service-queue self)
                    (sleep *worker-poll-interval*))
-      (/debug "exiting"))))
+      (/debug "stopping"))))

src/protocol.lisp

@@ -46,11 +46,11 @@
   (:uri uri)
   (:range range))
 
-(define-union progress-token
+(define-union token
     (integer string))
 
 (define-message work-done-progress-params ()
-  (:work-done-token progress-token))
+  (:work-done-token token))
 
 ;;; Errors
 
@@ -516,7 +516,7 @@
 (define-message diagnostic ()
   (:range range)
   (:severity (diagnostic-severity :optional t))
-  (:code (string :optional t))          ; FIXME union int | str
+  (:code (token :optional t))
   (:source (string :optional t))
   (:message string)
   (:tags (diagnostic-tag :vector t :optional t))

src/session.lisp

@@ -70,15 +70,15 @@
     (let ((uri (cdr (assoc "uri" document :test #'string=))))
       (/info "open ~a" uri)
       (cond ((gethash uri (session-documents session))
-             (/info "already open ~a" uri))
+             (/warn "already open ~a" uri))
             (t
              (setf (gethash uri (session-documents session)) document)
              (submit-event session 'document-opened uri))))))
 
-(defun change-document (session document) ; FIXME endpoint
+(defun change-document (session document)
   (with-session-context (session)
     (let ((uri (cdr (assoc "uri" document :test #'string=))))
-      (submit-event session 'document-opened uri))))
+      (submit-event session 'document-changed uri))))
 
 (defclass uri-source ()
   ((uri :initarg :uri)))
@@ -119,7 +119,7 @@
 
 (defun make-diagnostics (c)
   (mapcar (lambda (e)
-            (let ((coalton-impl/settings:*coalton-print-unicode* nil)) ; -> ? wut
+            (let ((coalton-impl/settings:*coalton-print-unicode* nil))
               (destructuring-bind (note message start end) e
                 (message-value
                  (make-diagnostic (car start) (cdr start)
@@ -140,13 +140,17 @@
           (coalton-impl/source::source-condition (c)
             (make-diagnostics c)))))))
 
-(defun document-opened (session uri)
-  (let* ((diagnostics (compile-uri uri))
-         (message (make-message 'text-document-publish-diagnostics-params)))
+(defun update-diagnostics (session uri)
+  (let ((message (make-message 'text-document-publish-diagnostics-params)))
     (set-field message :uri uri)
-    (set-field message :diagnostics diagnostics)
-    (let ((notification (make-notification "textDocument/publishDiagnostics" message)))
-      (submit-event session 'write-message notification))))
+    (set-field message :diagnostics (compile-uri uri))
+    (notify session "textDocument/publishDiagnostics" message)))
+
+(defun document-opened (session uri)
+  (update-diagnostics session uri))
+
+(defun document-changed (session uri)
+  (update-diagnostics session uri))
 
 (defun session-stream (session)
   (usocket:socket-stream (slot-value session 'socket)))
@@ -189,6 +193,9 @@
       (set-field notification :params (message-value params))
       notification)))
 
+(defun notify (session method value)
+  (submit-event session 'write-message (make-notification method value)))
+
 (defun message-p (message message-class)
   (eq (name (slot-value message 'class)) message-class))
 

tests/session-tests.lisp

@@ -24,7 +24,7 @@
 
 (deftest session-tests/set-field ()
   (let ((params (lsp::make-message 'lsp::initialize-params)))
-    (lsp::message-value (lsp::set-field-1 params :capabilities 'x)))
+    (lsp::message-value (lsp::%set-key params :capabilities 'x)))
   (let ((params (lsp::make-message 'lsp::initialize-params)))
     (lsp::set-field params '(:capabilities :workspace) 'x)))