added very basic file support, no fileedit syncing yet

Makefile

@@ -1,7 +1,14 @@
 STATIC_LUA_LIB=/usr/lib/liblua.so.5.4
 LUA_INCLUDE_PATH=$(shell lua5.4 -e 'print(package.cpath:match("[^;]+"))')
 SOURCES=$(wildcard *.fnl)
+SOURCES+=$(wildcard fls/*.fnl)
+
+.PHONY: test
 
 fennel-ls: $(SOURCES)
 	fennel --compile-binary main.fnl fennel-ls $(STATIC_LUA_LIB) $(LUA_INCLUDE_PATH)
 
+test:
+	@echo testing
+	fennel test.fnl
+

fennel-ls.fnl

@@ -1,9 +1,11 @@
+(local fennel (require :fennel))
+(local {: make-error-message} (require :fls.error))
+
 (local requests [])
 (local notifications [])
 
 (local capabilities
-  {:positionEncoding "utf-8"
-   :textDocumentSync nil
+  {:textDocumentSync 2
    :notebookDocumentSync nil
    :completionProvider nil
    :hoverProvider nil
@@ -34,54 +36,54 @@
    :inlineValueProvider nil
    :inlayHintProvider nil
    :diagnosticProvider nil
-   :workspaceSymbolProvider nil
-   :workspace {:workspaceFolders nil
-               :fileOperations {:didCreate nil
-                                :willCreate nil
-                                :didRename nil
-                                :willRename nil
-                                :didDelete nil
-                                :willDelete nil}}})
+   :workspaceSymbolProvider nil})
+;   :workspace {:workspaceFolders nil
+;               :fileOperations {:didCreate nil
+;                                :willCreate nil
+;                                :didRename nil
+;                                :willRename nil
+;                                :didDelete nil
+;                                :willDelete nil})
 
-(λ requests.initialize [params]
+(λ requests.initialize [self params]
   {:capabilities capabilities
    :serverInfo {:name "fennel-ls" :version "0.0.0"}})
 
-(λ requests.shutdown [])
-  ;; no op
+(λ requests.shutdown [self])
+  ;; Okay, I'll wait for the exit notification to actaully exit
 
-(λ notifications.exit []
+(λ notifications.exit [self]
   (os.exit 0))
 
-(λ handle-request [id method ?params]
-  (let [callback (. requests method)
-        result {: id :jsonrpc "2.0"}]
-    (if callback
-      (tset result :result (callback ?params))
-      (tset result :error (.. "Unknown message type: " method)))
-    result))
+(λ run-request [self id method ?params]
+  (match (. requests method)
+    callback {:jsonrpc "2.0"
+              : id
+              :result (callback self ?params)}
+    nil (make-error-message
+          :MethodNotFound
+          (.. "\"" method "\" is not in the requests table")
+          id)))
 
-(λ handle-response [id result])
-  ;; Do nothing
+(λ run-response [self id result])
+  ;; I don't care about responses yet
 
-(λ handle-bad-response [id err]
+(λ run-bad-response [self id err]
   (error (.. "oopsie: " err.code)))
 
-(λ handle-notification [method ?params]
-  (let [callback (. notifications method)]
-    (if callback
-      (callback ?params))))
+(λ run-notification [self method ?params]
+  (match (. notifications method)
+    callback (callback self ?params)
+    nil nil)) ;; Silent error for unknown notifications
 
-(λ handle [msg]
+(λ run [self msg]
   "The entry point for all messages."
-  (assert (= msg.jsonrpc "2.0") "Aha! You forgot to repeat that jsonrpc is version 2.0!")
-  (match msg
-    {: id : method :params ?params} (handle-request id method ?params)
-    {: method :params ?params}      (handle-notification method ?params)
-    {: id : result}                 (handle-response id result)
-    {: id :error err}               (handle-bad-response id err)
-    _ {:id msg.id
-       :error "I just received a message that doesn't make sense to me"
-       :jsonrpc "2.0"}))
+  (match (values msg (type msg))
+    {:jsonrpc "2.0" : id : method :params ?params} (run-request      self id method ?params)
+    {:jsonrpc "2.0" : method :params ?params}      (run-notification self method ?params)
+    {:jsonrpc "2.0" : id : result}                 (run-response     self id result)
+    {:jsonrpc "2.0" : id :error err}               (run-bad-response self id err)
+    (str :string)                                  (make-error-message :ParseError str)
+    _                                              (make-error-message :BadMessage nil msg.id)))
 
-{: handle}
+{: run}

fls/error.fnl

@@ -0,0 +1,23 @@
+(local error-codes
+  {;; JSON-RPC errors
+   :ParseError     -32700
+   :InvalidRequest -32600
+   :MethodNotFound -32601
+   :InvalidParams  -32602
+   :InternalError  -32603
+   ;; LSP errors
+   :ServerNotInitialized -32002
+   :UnknownErrorCode     -32001
+   :RequestFailed        -32802 ;; when the server has no excuse
+   :ServerCancelled      -32802
+   :ContentModified      -32801 ;; I don't think this one is useful
+   :RequestCancelled     -32800}) ;; I don't think I'm going to even support cancelling things, that sounds like a pain
+
+(λ make-error-message [code message ?id ?data]
+  {:jsonrpc "2.0"
+   :id ?id
+   :error {:code (or (. error-codes code) code)
+           :data ?data
+           : message}})
+
+{: error-codes : make-error-message}

fls/init.fnl

@@ -0,0 +1,4 @@
+{:error (require :fls.error)
+ :io (require :fls.io)
+ :state (require :fls.state)
+ :log (require :fls.log)}

fls/io.fnl

@@ -0,0 +1,58 @@
+" Language Server Protocol I/O
+
+This module implements the parsing and formatting needed to read/write messages using the language server protocol.
+There are only two functions exposed here:
+
+* `read` receives a message from the client.
+* `write` sends a message to the client."
+
+;; TODO find json library that doesn't conflate missing fields with null
+(local {: encode : decode} (require :json.json))
+(local {: split} (require :pl.stringx))
+
+(λ read-header [in ?header]
+  (let [header (or ?header {})]
+    (match (in:read)
+      "\r" header ;; hit an empty line, I'm done reading
+      nil nil ;; hit end of stream, return nil
+      ;; reading an actual line
+      header-line
+      (let [[k v] (split header-line ": " 2)]
+        (tset header k (string.sub v 1 -2))
+        (read-header in header)))))
+
+(λ read-n [in len ?buffer]
+  "read a string of exactly `len` characters from the `in` stream.
+If there aren't enough bytes, return nil"
+  (local buffer (or ?buffer []))
+  (if (<= len 0)
+    (table.concat buffer)
+    (match (in:read len)
+      content
+      (read-n in
+              (- len (length content))
+              (doto buffer (table.insert content))))))
+
+(λ read-content [in header]
+  (read-n in (tonumber header.Content-Length)))
+
+(λ read [in]
+  "Reads the next Language Server Protocol message from the given input stream"
+  (let [(_success? result)
+        (-?>>
+          (read-header in)
+          (read-content in)
+          (pcall decode))]
+    result))
+
+
+(λ write [out msg]
+  "Writes a Language Server Protocol message to the given output stream"
+  (let [content (encode msg)
+        msg-stringified (.. "Content-Length: " (length content) "\r\n\r\n" content)]
+    (out:write msg-stringified)
+    (when out.flush
+      (out:flush))))
+
+{: read
+ : write}

fls/log.fnl

@@ -0,0 +1,16 @@
+(local fennel (require :fennel))
+(local disable-logs false)
+(if disable-logs
+  {:log #nil}
+  (let [logfile (io.open "/tmp/fennel.log" "w")]
+    (assert logfile)
+    (fn log [...]
+      (let [args []]
+        (for [i 1 (select :# ...)]
+          (table.insert args
+            (let [item (select i ...)]
+              (match (values item (type item))
+                (str :string) str
+                ?any (fennel.view ?any)))))
+        (logfile:write (table.concat args) "\n")))
+    {: log}))

fls/state.fnl

@@ -0,0 +1,36 @@
+(local stringx (require :pl.stringx))
+
+(λ open-uri [uri]
+  (local prefix "file://")
+  (assert (stringx.startswith uri prefix))
+  (let [path (string.sub uri 8)]
+    (io.open path)))
+
+(λ make-file [uri lines ?dirty]
+  {: uri
+   : lines
+   :dirty? ?dirty})
+
+(λ make-file-from-disk [uri]
+  (make-file
+    uri
+    (with-open [file (open-uri uri)]
+      (icollect [line (file:lines)]
+         line))
+    false))
+
+(fn add-file [self uri ?contents]
+  ;; assert file isn't loaded yet
+  (assert (not (. self.files uri)))
+  (tset
+    self.files
+    uri
+    (make-file-from-disk uri)))
+
+(fn new-state []
+  {:files {}})
+   ; :variables {}
+   ; :settings {}
+   ; :other-things {}
+
+{: new-state : add-file}

lsp-io.fnl

@@ -1,44 +0,0 @@
-(local {: encode : decode} (require :json.json))
-(local {: split} (require :pl.stringx))
-
-(λ read-header [in ?header]
-  (let [header (or ?header {})]
-    (match (in:read)
-      ;; base cases
-      "\r" header
-      nil nil
-      ;; reading an actual line
-      header-line
-      (let [[k v] (split header-line ": " 2)]
-        (tset header k (string.sub v 1 -2))
-        (read-header in header)))))
-
-(λ read-content [in header]
-  (let [len (tonumber header.Content-Length)
-        buffer []]
-    ;; TODO make this code as tolerable as possible
-    (var sofar 0)
-    (var currently-read-bytes nil)
-    (while
-      (and (< sofar len)
-           (do (set currently-read-bytes (in:read (- len sofar)))
-               currently-read-bytes))
-      (set sofar (+ sofar (length currently-read-bytes)))
-      (table.insert buffer currently-read-bytes))
-    (decode (table.concat buffer))))
-
-
-(λ read-message [in]
-  (match (read-header in)
-    header (read-content in header)
-    nil nil))
-
-(λ write-message [out msg]
-  (let [content (encode msg)
-        msg-stringified (.. "Content-Length: " (length content) "\r\n\r\n" content)]
-    (out:write msg-stringified)
-    (when out.flush
-      (out:flush))))
-
-{: read-message
- : write-message}

main.fnl

@@ -1,16 +1,21 @@
 (local fennel (require :fennel))
-(local {: read-message : write-message} (require :lsp-io))
-(local {: handle} (require :fennel-ls))
+(local fls (require :fls))
+(local {: run} (require :fennel-ls))
+(local {: make-error-message} (require :fls.error))
 
-(λ main-loop [in out]
-  (let [msg (read-message in)]
-    (when msg
-      (let [response (handle msg)]
-        (when response
-          (write-message out response))
-        (main-loop in out)))))
+(λ main-loop [in out state]
+  (while
+    (let [msg (fls.io.read in)]
+        (fls.log.log msg)
+        (-?>> msg
+          (run state)
+          (fls.io.write out))
+      msg)))
 
 (λ main []
-  (main-loop (io.input) (io.output)))
+  (main-loop
+    (io.input)
+    (io.output)
+    (fls.state.new-state)))
 
 (main)

test.fnl

@@ -1,9 +1,10 @@
-(local {: handle} (require :fennel-ls))
-(local {: read-message : write-message} (require :lsp-io))
+(local fennel (require :fennel))
+(local fls (require :fls))
 (local stringio (require :pl.stringio))
-(local {: view} (require :fennel))
-(local busted (require :busted))
+(local stringx (require :pl.stringx))
+(local {: run} (require :fennel-ls))
 
+(local busted (require :busted))
 ((require :busted.runner))
 
 (macro it! [title ...]       `(busted.it ,title (fn [] ,...)))
@@ -11,28 +12,41 @@
 
 (describe! "fennel-ls"
 
+  (describe! "fls.io"
     (it! "parses incoming messages"
       (let [out (stringio.open "Content-Length: 29\r\n\r\n{\"my json content\":\"is cool\"}")]
         (assert.same {"my json content" "is cool"}
-                   (read-message out))))
+                     (fls.io.read out))))
 
     (it! "serializes outgoing messages"
       (let [in (stringio.create)]
-      (write-message in {"my json content" "is cool"})
+        (fls.io.write in {"my json content" "is cool"})
         (assert.same "Content-Length: 29\r\n\r\n{\"my json content\":\"is cool\"}"
                      (in:value))))
 
-  (it! "can read multiple messages"
+    (it! "can read multiple incoming messages"
       (let [out (stringio.open "Content-Length: 29\r\n\r\n{\"my json content\":\"is cool\"}Content-Length: 29\r\n\r\n{\"my json content\":\"is cool\"}")]
         (assert.same {"my json content" "is cool"}
-                   (read-message out))
+                     (fls.io.read out))
         (assert.same {"my json content" "is cool"}
-                   (read-message out))
+                     (fls.io.read out))
         (assert.same nil
-                   (read-message out))))
+                     (fls.io.read out))))
 
+    (it! "can report the ParseError code"
+      (let [out (stringio.open "Content-Length: 9\r\n\r\n{{{{{}}}}")]
+        (assert
+          (match (run [] (fls.io.read out))
+            {:error {:code -32700} :jsonrpc "2.0"}
+            true
+            otherwise (values false (fennel.view otherwise)))))))
+
+    ;; FIXME all of the other RPC codes
+
+  (describe! "initialization"
+    ;; TODO get rid of hardcoded paths here
     (it! "responds to initialize"
-    (local initialize-message
+      (local initialize
         {:id 1
          :jsonrpc "2.0"
          :method "initialize"
@@ -47,11 +61,27 @@
           :workspaceFolders [{:name "/home/xerool/Documents/projects/fennel-ls"
                               :uri "file:///home/xerool/Documents/projects/fennel-ls"}]}})
       (assert
-      (match (handle initialize-message)
+        (match (run [] initialize)
           {:id 1
            :jsonrpc "2.0"
            :result {:capabilities {}
                     :serverInfo {:name "fennel-ls" : version}}}
           true
-        otherwise (values false (view otherwise))))))
+          otherwise (values false (fennel.view otherwise))))))
+
+  (describe! "file syncing"
+    (it! "can open files from disk"
+      (local state (fls.state.new-state))
+      (assert state)
+      (local uri
+        (-> (io.popen "pwd")
+          (: :read :*a)
+          (stringx.strip)
+          (->> (.. "file://"))
+          (.. "/test.fnl")))
+
+      (fls.state.add-file state uri)
+      (assert (. state :files uri))
+      (assert.equal (. state :files uri :lines 1)
+                    "(local fennel (require :fennel))"))))