From 1953cd47c6abdec2437c833cb8e26cf1e8ac1834 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Mon, 9 Dec 2019 14:45:37 +0100 Subject: First actually working version of LSP --- src/json.sml | 11 ++-- src/lsp.sml | 187 +++++++++++++++++++++++++++++++++++------------------------ 2 files changed, 115 insertions(+), 83 deletions(-) diff --git a/src/json.sml b/src/json.sml index fab15a6c..f189cc4d 100644 --- a/src/json.sml +++ b/src/json.sml @@ -79,7 +79,7 @@ struct and parsePair () = Callbacks.json_pair (parseString (), - (ws(); consume ":"; parseValue ())) + (ws(); consume ":"; ws(); parseValue ())) and parseArray () = if not (matches "[") then @@ -142,10 +142,9 @@ struct and parseInt () = let val f = - if peek () = #"0" then - raise JSONParseError ("Invalid number", !inputPosition) - else if peek () = #"-" then (take (); "~") - else String.str (take ()) + if peek () = #"-" + then (take (); "~") + else String.str (take ()) in f ^ parseDigits () end @@ -270,6 +269,6 @@ fun print (ast: json): string = | Bool b => if b then "true" else "false" | Int i => Int.toString i | Obj l => "{" - ^ List.foldl (fn ((k, v), acc) => k ^ ": " ^ print v ) "" l + ^ List.foldl (fn ((k, v), acc) => acc ^ (if acc = "" then "" else ", ") ^ "\"" ^ k ^ "\": " ^ print v ) "" l ^ "}" end diff --git a/src/lsp.sml b/src/lsp.sml index 2ddce0e3..f3fed67c 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -1,4 +1,3 @@ - fun trim (s: substring): substring = Substring.dropr (fn c => c = #" " orelse c = #"\n" orelse c = #"\r") @@ -6,19 +5,12 @@ fun trim (s: substring): substring = structure FromJson = struct fun get (s: string) (l: Json.json): Json.json = - let - fun getJsonObjectValue (s: string) (l: (string * Json.json) list): Json.json option = - case List.find (fn tup => #1 tup = s ) l of - NONE => NONE - | SOME tup => SOME (#2 tup) - in - case l of - Json.Obj l => - (case getJsonObjectValue s l of - NONE => raise Fail ("Failed to find JSON object key " ^ s) - | SOME v => v) - | a => raise Fail ("Expected JSON object, got: " ^ Json.print a) - end + case l of + Json.Obj pairs => + (case List.find (fn tup => #1 tup = s) pairs of + NONE => raise Fail ("Failed to find JSON object key " ^ s ^ " in " ^ Json.print l) + | SOME tup => #2 tup) + | _ => raise Fail ("Expected JSON object, got: " ^ Json.print l) fun asInt (j: Json.json): int = case j of @@ -32,24 +24,6 @@ fun asString (j: Json.json): string = end -(* signature LSPSPEC = sig *) -(* type textDocumentIdentifier = *) -(* { scheme: string *) -(* , authority: string *) -(* , path: string *) -(* , query: string *) -(* , fragment: string *) -(* } *) -(* type position = { line: int *) -(* , character: int *) -(* } *) -(* val readRequestFromStdIO: () -> {id: Json.json, method: string, params: Json.json} *) -(* val parseRequest: {id: Json.json, method: string, params: Json.json} -> request *) -(* datatype request = *) -(* end *) - - - structure LspSpec (* :> LSPSPEC *) = struct fun readHeader (): (string * string) option = let @@ -57,15 +31,18 @@ structure LspSpec (* :> LSPSPEC *) = struct in case line of NONE => OS.Process.exit OS.Process.success - | SOME str => - let - val (key, value) = Substring.splitl (fn c => c <> #":") (Substring.full str) - in - if Substring.isEmpty (trim value) - then NONE - else SOME ( Substring.string (trim key) - , Substring.string (trim (Substring.dropl (fn c => c = #":") (trim value)))) - end + | SOME str => + if Substring.isEmpty (trim (Substring.full str)) + then NONE + else + let + val (key, value) = Substring.splitl (fn c => c <> #":") (Substring.full str) + in + if Substring.isEmpty (trim value) + then raise Fail ("Failed to parse LSP header: Line is not empty but is also not a valid header: " ^ str) + else SOME ( Substring.string (trim key) + , Substring.string (trim (Substring.dropl (fn c => c = #":") (trim value)))) + end end fun readAllHeaders (): (string * string) list = @@ -78,14 +55,19 @@ structure LspSpec (* :> LSPSPEC *) = struct in doReadAllHeaders [] end - - fun parseBasicRequest (j: Json.json): {id: Json.json, method: string, params: Json.json} = + datatype message = + RequestMessage of { id: Json.json, method: string, params: Json.json} + | Notification of { method: string, params: Json.json} + fun parseMessage (j: Json.json): message = let - val id = FromJson.get "id" j + val id = SOME (FromJson.get "id" j) + handle ex => NONE val method = FromJson.asString (FromJson.get "method" j) val params = FromJson.get "params" j in - {id = id, method = method, params = params} + case id of + NONE => Notification {method = method, params = params} + | SOME id => RequestMessage {id = id, method = method, params = params} end type textDocumentIdentifier = @@ -125,8 +107,7 @@ structure LspSpec (* :> LSPSPEC *) = struct , character = FromJson.asInt (FromJson.get "character" j) } - - fun readRequestFromStdIO (): {id: Json.json, method: string, params: Json.json} = + fun readRequestFromStdIO (): message = let val headers = readAllHeaders () val lengthO = List.find (fn (k,v) => k = "Content-Length") headers @@ -138,7 +119,7 @@ structure LspSpec (* :> LSPSPEC *) = struct | SOME i => TextIO.inputN (TextIO.stdIn, i) val parsed = Json.parse request in - parseBasicRequest parsed + parseMessage parsed end fun parseHoverReq (params: Json.json): { textDocument: textDocumentIdentifier , position: position } = @@ -146,8 +127,10 @@ structure LspSpec (* :> LSPSPEC *) = struct , position = parsePosition (FromJson.get "position" params) } - fun printHoverResponse (resp: {contents: string}): Json.json = - Json.Obj (("contents", Json.String (#contents resp)) :: []) + fun printHoverResponse (resp: {contents: string} option): Json.json = + case resp of + NONE => Json.Null + | SOME obj => Json.Obj [("contents", Json.String (#contents obj))] datatype 'a result = Success of 'a @@ -157,31 +140,38 @@ structure LspSpec (* :> LSPSPEC *) = struct case a of Success contents => Success (f contents) | Error e => Error e - type handlers = + type messageHandlers = { initialize: unit -> { capabilities: {hoverProvider: bool}} result , shutdown: unit -> unit result - , textDocument_hover: { textDocument: textDocumentIdentifier - , position: position } - -> {contents: string} result + , textDocument_hover: + { showMessage: string -> int -> unit} + -> { textDocument: textDocumentIdentifier + , position: position } + -> ({contents: string} option) result } - fun handleRequest + fun handleMessage (requestMessage: {id: Json.json, method: string, params: Json.json}) - (handlers: handlers) + (handlers: messageHandlers) : unit = let + fun showMessage str typ = + TextIO.print (Json.print (Json.Obj [ ("method", Json.String "window/showMessage") + , ("params", Json.Obj [ ("type", Json.Int typ) + , ("message", Json.String str)]) + ])); + val result: Json.json result = case #method requestMessage of "initialize" => mapResult - (fn res => Json.Obj (("capabilities", Json.Obj (("hoverProvider", Json.Bool (#hoverProvider (#capabilities res))) - :: [])) - :: [])) + (fn res => Json.Obj [("capabilities", Json.Obj [("hoverProvider", Json.Bool (#hoverProvider (#capabilities res)))])]) ((#initialize handlers) ()) | "textDocument/hover" => mapResult printHoverResponse ((#textDocument_hover handlers) + {showMessage = showMessage} (parseHoverReq (#params requestMessage))) | "shutdown" => mapResult @@ -190,21 +180,47 @@ structure LspSpec (* :> LSPSPEC *) = struct | "exit" => OS.Process.exit OS.Process.success | method => Error (~32601, "Method not supported: " ^ method) + (* val () = (TextIO.output (TextIO.stdErr, "Got result: " ^ (case result of Success _ => "success\n" *) + (* | Error _ => "error\n")); TextIO.flushOut TextIO.stdErr) *) in case result of - Success j => TextIO.output (TextIO.stdOut, - Json.print (Json.Obj (("id", #id requestMessage) - :: ("result", j) - :: []))) + Success j => + let + val jsonToPrint = + Json.print (Json.Obj [ ("id", #id requestMessage) + , ("jsonrpc", Json.String "2.0") + , ("result", j) + ]) + val toPrint = "Content-Length:" ^ Int.toString (String.size jsonToPrint) ^ "\r\n\r\n" ^ jsonToPrint + in + TextIO.print toPrint + end | Error (i, err) => - TextIO.output (TextIO.stdOut, - Json.print (Json.Obj (("id", #id requestMessage) - :: ("error", Json.Obj (("code", Json.Int i) - :: ("message", Json.String err) - :: [])) - :: [] - ))) + let + val jsonToPrint = + Json.print (Json.Obj [ ("id", #id requestMessage) + , ("jsonrpc", Json.String "2.0") + , ("error", Json.Obj [ ("code", Json.Int i) + , ("message", Json.String err) + ]) + ]) + val toPrint = "Content-Length:" ^ Int.toString (String.size jsonToPrint) ^ "\r\n\r\n" ^ jsonToPrint + in + TextIO.print toPrint + end end + + type notificationHandlers = + { initialized: unit -> unit + } + fun handleNotification + (notification: {method: string, params: Json.json}) + (handlers: notificationHandlers) + = case #method notification of + "initialized" => (#initialized handlers) () + | m => (TextIO.output ( TextIO.stdErr, "Notification method not supported: " ^ m); + TextIO.flushOut TextIO.stdErr) + end @@ -212,14 +228,31 @@ structure Lsp :> LSP = struct fun serverLoop () = let - val requestMessage = LspSpec.readRequestFromStdIO () + val requestMessage = + LspSpec.readRequestFromStdIO () + handle ex => (TextIO.output (TextIO.stdErr, General.exnMessage ex ^ "\n"); TextIO.flushOut TextIO.stdErr ; raise ex) in - LspSpec.handleRequest - requestMessage - { initialize = fn () => LspSpec.Success {capabilities = {hoverProvider = true}} - , shutdown = fn () => LspSpec.Success () - , textDocument_hover = fn _ => LspSpec.Success {contents = ""} - } + (case requestMessage of + LspSpec.Notification n => + ((* TextIO.output (TextIO.stdErr, "Handling notification: " ^ #method n ^ "\n"); *) + (* TextIO.flushOut TextIO.stdErr; *) + LspSpec.handleNotification + n + { initialized = fn () => () + }) + | LspSpec.RequestMessage m => + ((* TextIO.output (TextIO.stdErr, "Handling message: " ^ #method m ^ "\n"); *) + (* TextIO.flushOut TextIO.stdErr; *) + LspSpec.handleMessage + m + { initialize = fn () => LspSpec.Success {capabilities = {hoverProvider = true}} + , shutdown = fn () => LspSpec.Success () + , textDocument_hover = + fn ctx => + fn _ => LspSpec.Success NONE + } + ) + ) handle ex => (TextIO.output (TextIO.stdErr, General.exnMessage ex ^ "\n"); TextIO.flushOut TextIO.stdErr ; raise ex) end fun startServer () = while true do serverLoop () -- cgit v1.2.3