From 01f76e4c4f57bdd5da64bae884e7b9858da0e680 Mon Sep 17 00:00:00 2001
From: XeroOl <xerool@protonmail.com>
Date: Mon, 1 Aug 2022 14:12:42 -0500
Subject: [PATCH] added all of the code

---
 .gitignore                        |   2 +-
 src/fennel-ls/dispatch.fnl        |  72 +++++++++++++++++
 src/fennel-ls/json-rpc.fnl        |  64 +++++++++++++++
 src/fennel-ls/log.fnl             |  20 +++++
 src/fennel-ls/message.fnl         |  50 ++++++++++++
 src/fennel-ls/mod.fnl             |  30 +++++++
 src/fennel-ls/parser.fnl          |  37 +++++++++
 src/fennel-ls/state.fnl           |  52 ++++++++++++
 src/fennel-ls/the-actual-code.fnl | 128 ++++++++++++++++++++++++++++++
 src/fennel-ls/util.fnl            |  74 +++++++++++++++++
 10 files changed, 528 insertions(+), 1 deletion(-)
 create mode 100644 src/fennel-ls/dispatch.fnl
 create mode 100644 src/fennel-ls/json-rpc.fnl
 create mode 100644 src/fennel-ls/log.fnl
 create mode 100644 src/fennel-ls/message.fnl
 create mode 100644 src/fennel-ls/mod.fnl
 create mode 100644 src/fennel-ls/parser.fnl
 create mode 100644 src/fennel-ls/state.fnl
 create mode 100644 src/fennel-ls/the-actual-code.fnl
 create mode 100644 src/fennel-ls/util.fnl

diff --git a/.gitignore b/.gitignore
index f07c601..ca7d968 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1 +1 @@
-fennel-ls
+^fennel-ls$
diff --git a/src/fennel-ls/dispatch.fnl b/src/fennel-ls/dispatch.fnl
new file mode 100644
index 0000000..1a19f1d
--- /dev/null
+++ b/src/fennel-ls/dispatch.fnl
@@ -0,0 +1,72 @@
+"Dispatch
+This module is responsible for deciding which code to call in response
+to a given LSP request from the client.
+
+In general, this involves:
+* parsing the message
+* determining the type of the message
+* calling the appropriate handler"
+
+(local handlers (require :fennel-ls.the-actual-code))
+(local message (require :fennel-ls.message))
+
+(λ handle-request [self send id method ?params]
+  "Call the appropriate request handler.
+The return value of the request is sent back to the server."
+  (match (. handlers.requests method)
+    callback
+    (match (callback self send ?params)
+      (nil err) (send (message.create-error :InternalError err id))
+      ?response (send (message.create-response id ?response)))
+    nil
+    (send
+      (message.create-error
+        :MethodNotFound
+        (.. "\"" method "\" is not in the request-handlers table")
+        id))))
+
+(λ handle-response [self send id result]
+  "I don't care about responses yet"
+  nil)
+
+(λ handle-bad-response [self send id err]
+  "Handle a message indicating an error. Right now, it just crashes the server."
+  (error (.. "oopsie: " err.code)))
+
+(λ handle-notification [self send method ?params]
+  "Call the appropriate notification handler."
+  (match (. handlers.notifications method)
+    callback (callback self send ?params)))
+    ;; Silent error for unknown notifications
+
+(λ handle [self send msg]
+  "Figures out what to do with a message.
+This can involve updating the state of the server, and/or sending messages to the
+server.
+
+Takes:
+* `self`, which is the state of the server,
+* `send`, which is a callback for sending responses, and
+* `msg`, which is the message to receive."
+  (match (values msg (type msg))
+    {:jsonrpc "2.0" : id : method :params ?params}
+    (handle-request self send id method ?params)
+    {:jsonrpc "2.0" : method :params ?params}
+    (handle-notification self send method ?params)
+    {:jsonrpc "2.0" : id : result}
+    (handle-response self send id result)
+    {:jsonrpc "2.0" : id :error err}
+    (handle-bad-response self send id err)
+    (str :string)
+    (send (message.create-error :ParseError str))
+    _
+    (send (message.create-error :BadMessage nil msg.id))))
+
+(λ handle* [self msg]
+  "handles a message, and returns all the responses in a table"
+  (let [out []]
+    (handle self (partial table.insert out) msg)
+    out))
+
+{: handle
+ : handle*}
diff --git a/src/fennel-ls/json-rpc.fnl b/src/fennel-ls/json-rpc.fnl
new file mode 100644
index 0000000..3d7881e
--- /dev/null
+++ b/src/fennel-ls/json-rpc.fnl
@@ -0,0 +1,64 @@
+"JSON-RPC
+This module implements the parsing and formatting code needed to read/write messages over the language server protocol.
+There are only two functions exposed here:
+
+* `read` receives and parses a message from the client.
+* `write` serializes and sends a message to the client.
+
+It's probably not compliant yet, because serialization of [] and {} is the same,
+and there are also some places where a field has to be present, but filled with null.
+
+Luckily, I'm testing with Neovim, so I can pretend these problems don't exist for now."
+
+;; 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]
+  "Reads the header of a JSON-RPC message"
+  (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]
+  "Reads the content of a JSON-RPC message given the header"
+  (read-n in (tonumber header.Content-Length)))
+
+(λ read [in]
+  "Reads and parses a JSON-RPC message from the input stream
+Returns a table with the message if it succeeded, or a string with the parse error if it fails."
+  (let [(_success? result)
+        (-?>> (read-header in)
+          (read-content in)
+          (pcall decode))]
+    result))
+
+
+(λ write [out msg]
+  "Serializes and writes a JSON-RPC 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}
diff --git a/src/fennel-ls/log.fnl b/src/fennel-ls/log.fnl
new file mode 100644
index 0000000..9a1a345
--- /dev/null
+++ b/src/fennel-ls/log.fnl
@@ -0,0 +1,20 @@
+"Log
+In the Language Server Protocol, io.stdout is used to send messages to the client.
+Because of this, I need another way to do print-debugging."
+
+(local fennel (require :fennel))
+(local disable-logs false)
+(if disable-logs
+  {:log #nil}
+  (let [logdocument (io.open "/tmp/fennel.log" "w")]
+    (assert logdocument)
+    (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)))))
+        (logdocument:write (table.concat args) "\n")))
+    {: log}))
diff --git a/src/fennel-ls/message.fnl b/src/fennel-ls/message.fnl
new file mode 100644
index 0000000..6a618c3
--- /dev/null
+++ b/src/fennel-ls/message.fnl
@@ -0,0 +1,50 @@
+"Message
+Here are all the constructors for the various JSON-RPC responses
+that may need to be sent to the client.
+
+I have them all here because I have a feeling I am conflating missing fields with null fields,
+and I want to have one location to look to fix this in the future."
+
+(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 for failure
+   :ServerCancelled      -32802
+   :ContentModified      -32801 ;; I don't think this one is useful unless we do async things
+   :RequestCancelled     -32800}) ;; I don't think I'm going to even support cancelling things, that sounds like a pain
+
+(λ create-error [code message ?id ?data]
+  {:jsonrpc "2.0"
+   :id ?id
+   :error {:code (or (. error-codes code) code)
+           :data ?data
+           : message}})
+
+(λ create-request [id method ?params]
+  {:jsonrpc "2.0"
+   : id
+   : method
+   :params ?params})
+
+(λ create-notification [method ?params]
+  {:jsonrpc "2.0"
+   : method
+   :params ?params})
+
+(λ create-response [id ?result]
+  {:jsonrpc "2.0"
+   : id
+   :result ?result})
+
+{: create-notification
+ : create-request
+ : create-response
+ : create-error}
+ 
diff --git a/src/fennel-ls/mod.fnl b/src/fennel-ls/mod.fnl
new file mode 100644
index 0000000..e988fc2
--- /dev/null
+++ b/src/fennel-ls/mod.fnl
@@ -0,0 +1,30 @@
+"Mod
+This file has all the logic needed to take the name of a module and find the corresponding URI.
+I suspect this file is going to be gone after a bit of refactoring."
+
+(local fennel (require :fennel))
+(local stringx (require :pl.stringx))
+(local plpath (require :pl.path))
+(local util (require :fennel-ls.util))
+
+"works on my machine >:)"
+(local luapath "?.lua;src/?.lua")
+(local fennelpath "?.fnl;src/?.fnl")
+
+(fn add-workspaces-to-path [path ?workspaces]
+  (let [paths (stringx.split path ";")
+        result []]
+    (each [_ path (ipairs paths)]
+      (if (plpath.isabs path)
+        (table.insert result path)
+        (each [_ space (ipairs (or ?workspaces []))]
+          (table.insert result (plpath.normpath (plpath.join (util.uri->path space) path))))))
+    (table.concat result ";")))
+
+(fn lookup [{: root-uri} mod]
+  (match (or (fennel.searchModule mod (add-workspaces-to-path luapath [root-uri]))
+             (fennel.searchModule mod (add-workspaces-to-path fennelpath [root-uri])))
+    modname (util.path->uri modname)
+    nil nil))
+
+{: lookup}
diff --git a/src/fennel-ls/parser.fnl b/src/fennel-ls/parser.fnl
new file mode 100644
index 0000000..5e58fcf
--- /dev/null
+++ b/src/fennel-ls/parser.fnl
@@ -0,0 +1,37 @@
+(local fennel (require :fennel))
+(local util (require :fennel-ls.util))
+
+(fn get-ast-info [ast info]
+  "find a given key of info from an AST object"
+  (or (. (getmetatable ast) info)
+      (. ast info)))
+
+(fn contains? [ast byte]
+  "check if a byte is in range of the AST object"
+  (and (= (type ast) :table)
+       (<= (get-ast-info ast :bytestart)
+           byte
+           (get-ast-info ast :byteend))))
+
+(fn past? [ast byte]
+  "check if a byte is past the range of the AST object"
+  (and (= (type ast) :table)
+       (< byte (get-ast-info ast :bytestart))))
+
+(fn range [ast]
+  "create a LSP range representing the span of an AST object"
+  (if (= (type ast) :table)
+    (match (values (get-ast-info ast :bytestart) (get-ast-info ast :byteend))
+      (i j)
+      (let [(start-line start-col) (util.byte->pos i)
+            (end-line   end-col)   (util.byte->pos j)]
+        {:start {:line start-line :character start-col}
+         :end   {:line end-line   :character end-col}}))))
+
+(fn from-fennel [file]
+  (icollect [k v (fennel.parser file.text file.uri)]
+      v))
+
+{: from-fennel
+ : contains?
+ : past?}
diff --git a/src/fennel-ls/state.fnl b/src/fennel-ls/state.fnl
new file mode 100644
index 0000000..86fa71f
--- /dev/null
+++ b/src/fennel-ls/state.fnl
@@ -0,0 +1,52 @@
+(local util (require :fennel-ls.util))
+(local mod (require :fennel-ls.mod))
+
+(λ analyze [] "TODO")
+
+(λ init-state [self params]
+  (set self.files {})
+  (set self.modules {})
+  (set self.root-uri params.rootUri))
+
+(λ read-file [uri]
+  (with-open [fd (io.open (util.uri->path uri))]
+    {:uri uri
+     :text (fd:read :*a)}))
+
+(λ get-by-uri [self uri]
+  (or (. self.files uri)
+      (let [file (read-file uri)]
+        (analyze file)
+        (tset self.files uri file)
+        file)))
+
+(λ get-by-module [self module]
+  (match (. self.modules module)
+    uri (or (get-by-uri self uri)
+          ;; if the cached uri isn't found, clear the cache and try again
+          (do (tset self.modules module nil)
+              (get-by-module self module)))
+    nil (let [uri (mod.lookup self module)]
+          (tset self.modules module uri)
+          (get-by-uri self uri))))
+
+(λ set-uri-contents [self uri text]
+  (if (. self.files uri)
+    ;; modify existing file
+    (let [file (. self.files uri)]
+      (when (not= text file.text)
+        (set file.text text)
+        (analyze file)
+        file))
+    ;; create new file
+    (let [file {: uri : text}]
+        (tset self.files uri file)
+        (analyze file)
+        file)))
+
+
+
+{: get-by-uri
+ : get-by-module
+ : set-uri-contents
+ : init-state}
diff --git a/src/fennel-ls/the-actual-code.fnl b/src/fennel-ls/the-actual-code.fnl
new file mode 100644
index 0000000..caec16c
--- /dev/null
+++ b/src/fennel-ls/the-actual-code.fnl
@@ -0,0 +1,128 @@
+"The actual code
+You finally made it. Here is the main code that implements the language server protocol
+
+Every time the client sends a message, it gets handled by a function in the corresponding table type.
+(ie, a textDocument/didChange notification will call notifications.textDocument/didChange
+ and a textDocument/defintion request will call requests.textDocument/didChange)"
+(local fennel (require :fennel))
+(local dir (require :pl.dir))
+
+(local parser  (require :fennel-ls.parser))
+(local util    (require :fennel-ls.util))
+(local mod     (require :fennel-ls.mod))
+(local {: log} (require :fennel-ls.log))
+(local state   (require :fennel-ls.state))
+
+(local requests [])
+(local notifications [])
+
+(local capabilities
+  {:textDocumentSync 1 ;; FIXME: upgrade to 2
+   ;; :notebookDocumentSync nil
+   ;; :completionProvider nil
+   ;; :hoverProvider nil
+   ;; :signatureHelpProvider nil
+   ;; :declarationProvider nil
+   :definitionProvider {:workDoneProgress false}})
+   ;; :typeDefinitionProvider nil
+   ;; :implementationProvider nil
+   ;; :referencesProvider nil
+   ;; :documentHighlightProvider nil
+   ;; :documentSymbolProvider nil
+   ;; :codeActionProvider nil
+   ;; :codeLensProvider nil
+   ;; :documentLinkProvider nil
+   ;; :colorProvider nil
+   ;; :documentFormattingProvider nil
+   ;; :documentRangeFormattingProvider nil
+   ;; :documentOnTypeFormattingProvider nil
+   ;; :renameProvider nil
+   ;; :foldingRangeProvider nil
+   ;; :executeCommandProvider nil
+   ;; :selectionRangeProvider nil
+   ;; :linkedEditingRangeProvider nil
+   ;; :callHierarchyProvider nil
+   ;; :semanticTokensProvider nil
+   ;; :monikerProvider nil
+   ;; :typeHierarchyProvider nil
+   ;; :inlineValueProvider nil
+   ;; :inlayHintProvider nil
+   ;; :diagnosticProvider {:workDoneProgress false}})
+   ;; :workspaceSymbolProvider nil
+   ;; :workspace {:workspaceFolders nil
+   ;;             :documentOperations {:didCreate nil
+   ;;                              :willCreate nil
+   ;;                              :didRename nil
+   ;;                              :willRename nil
+   ;;                              :didDelete nil
+   ;;                              :willDelete nil}})
+
+(λ requests.initialize [self send params]
+  (state.init-state self params)
+  {:capabilities capabilities
+   :serverInfo {:name "fennel-ls" :version "0.0.0"}})
+
+(fn string? [j]
+  (= (type j) :string))
+
+(local require* (fennel.sym :require))
+(local local* (fennel.sym :local))
+(λ requests.textDocument/definition [self send {: position :textDocument {: uri}}]
+  (local file (state.get-by-uri self uri))
+
+  (set file.ast (or file.ast
+                    (parser.from-fennel (. self.files uri))))
+  (local ast file.ast)
+
+  (local byte (util.pos->byte file.text position.line position.character))
+
+  (var result nil)
+  (λ check [ast]
+    (log (fennel.view ast))
+    (each [_ item (ipairs ast) :until (or result (parser.past? item byte))]
+      (log (fennel.view ast))
+      (if (parser.contains? item byte)
+        (match item
+          (where [require* module &as l]
+                 (and (fennel.list? l)
+                      (string? module)))
+          (set result module)
+          (where [local* _ [require* module &as l1] &as l2]
+                 (and (fennel.list? l1)
+                      (fennel.list? l2)
+                      (string? module)))
+          (set result module)
+          (where obj (fennel.list? obj))
+          (check obj)))))
+
+  (check ast)
+
+  (if result
+    {:uri (mod.lookup self result)
+     :range {:start {:line 0 :character 0}
+             :end {:line 0 :character 0}}}))
+
+
+(λ notifications.textDocument/didChange [self send {: contentChanges :textDocument {: uri}}]
+  (local file (state.get-by-uri self uri))
+  (assert file.open?)
+  (util.apply-changes (. self.files uri) contentChanges))
+
+(λ notifications.textDocument/didOpen [self send {:textDocument {: languageId : text : uri}}]
+  (local file (state.set-uri-contents self uri text))
+  (set file.open? true))
+
+(λ notifications.textDocument/didClose [self send {:textDocument {: uri}}]
+  (local file (state.get-by-uri self uri))
+  (set file.open? false))
+
+(λ requests.shutdown [self send]
+  "The server still needs to respond to this request, so the program can't close yet. Wait until notifications.exit"
+  nil)
+
+(λ notifications.exit [self]
+  (os.exit 0))
+
+{: requests
+ : notifications}
+
diff --git a/src/fennel-ls/util.fnl b/src/fennel-ls/util.fnl
new file mode 100644
index 0000000..c8b1f54
--- /dev/null
+++ b/src/fennel-ls/util.fnl
@@ -0,0 +1,74 @@
+"Util
+A collection of utility functions. Many of these convert data between a
+Language-Server-Protocol representation and a Lua representation.
+These functions are all pure functions, which makes me happy."
+
+(local {: startswith} (require :pl.stringx))
+
+(λ uri->path [uri]
+  (local prefix "file://")
+  (assert (startswith uri prefix))
+  (string.sub uri (+ (length prefix) 1)))
+
+(λ path->uri [path]
+  (.. "file://" path))
+
+(λ next-line [str ?from]
+  "Find the start of the next line from a given byte offset, or from the start of the string."
+  (let [from (or ?from 1)]
+    (match (str:find "[\r\n]" from)
+      i (+ i (length (str:match "\r?\n?" i)))
+      nil nil)))
+
+(λ pos->byte [str line col]
+  "convert a 0-indexed line and column into a 1-indexed byte. Doesn't yet handle UTF8 UTF16 magic from the protocol"
+  (var sofar 1)
+  (for [i 1 line :until (not sofar)]
+    (set sofar (next-line str sofar)))
+  (if sofar
+    (+ sofar col)
+    nil))
+
+(λ byte->pos [str byte]
+  "convert a 1-indexed byte into a 0-indexed line and column. Doesn't yet handle UTF8 UTF16 magic from the protocol"
+  (local up-to (str:sub 1 (- byte 1)))
+  (var lines 0)
+  (var pos 1)
+  (var prev nil)
+  (while (do (set prev pos)
+             (set pos (next-line up-to pos))
+             pos)
+    (set lines (+ 1 lines)))
+  (values lines (+ (length up-to) (- prev) 1)))
+
+(λ replace [text start-line start-col end-line end-col replacement]
+  "Replaces a range of text with a replacement, using the protocol's definition of range. Doesn't yet handle UTF8 UTF16 magic from the protocol"
+  (let [start (pos->byte text start-line start-col)
+        end   (pos->byte text end-line   end-col)]
+    (..
+      (text:sub 1 (- start 1))
+      replacement
+      (text:sub end))))
+
+(λ apply-changes [initial-text contentChanges]
+  "Take's a list of Language-Server-Protocol contentChanges and applies them to a piece of text. Doesn't yet handle UTF8 UTF16 magic from the protocol"
+  (accumulate [contents initial-text
+               _ change (ipairs contentChanges)]
+    (match change
+      ;; Handle a change
+      {:range {: start : end} : text}
+      (replace contents
+        start.line
+        start.character
+        end.line
+        end.character
+        text)
+      ;; A replacment of the entire body
+      {: text}
+      text)))
+
+{: uri->path
+ : path->uri
+ : pos->byte
+ : byte->pos
+ : apply-changes}