From 26e16f90067ee294d1ccd6341547dbae585cdb3e Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Mon, 9 Dec 2019 11:47:57 +0100 Subject: Refactored LSP into few modules --- src/lsp.sml | 311 ++++++++++++++++++++++++++++++++++++------------------------ 1 file changed, 189 insertions(+), 122 deletions(-) diff --git a/src/lsp.sml b/src/lsp.sml index 1fd50109..2ddce0e3 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -1,141 +1,194 @@ -structure Lsp :> LSP = struct fun trim (s: substring): substring = Substring.dropr - (fn c => c = #" " orelse c = #"\n" orelse c = #"\r") - (Substring.dropl (fn c => c = #" " orelse c = #"\n" orelse c = #"\r") s) + (fn c => c = #" " orelse c = #"\n" orelse c = #"\r") + (Substring.dropl (fn c => c = #" " orelse c = #"\n" orelse c = #"\r") s) -fun readHeader (): (string * string) option = +structure FromJson = struct +fun get (s: string) (l: Json.json): Json.json = let - val line = TextIO.inputLine TextIO.stdIn + 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 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 + 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 -fun readAllHeaders (l: (string * string) list): (string * string) list = - case readHeader () of - NONE => l - | SOME tup => tup :: readAllHeaders l - -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) - -fun getJsonObjectValue' (s: string) (l: Json.json): Json.json = - 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) - -fun parseInt (j: Json.json): int = +fun asInt (j: Json.json): int = case j of Json.Int i => i | _ => raise Fail ("Expected JSON int, got: " ^ Json.print j) -fun parseString (j: Json.json): string = +fun asString (j: Json.json): string = case j of Json.String s => s | _ => raise Fail ("Expected JSON string, got: " ^ Json.print j) +end -fun parseRequest (j: Json.json): {id: Json.json, method: string, params: Json.json} = - let - val id = getJsonObjectValue' "id" j - val method = parseString (getJsonObjectValue' "method" j) - val params = getJsonObjectValue' "params" j - in - {id = id, method = method, params = params} - end - - -type textDocumentIdentifier = - { scheme: string - , authority: string - , path: string - , query: string - , fragment: string - } -fun parseTextDocumentIdentifier (j: Json.json): textDocumentIdentifier = - let - val str = Substring.full (parseString (getJsonObjectValue' "uri" j)) - val (scheme, rest) = Substring.splitl (fn c => c <> #":") str - val (authority, rest) = Substring.splitl (fn c => c <> #"/") (Substring.triml 3 rest (* :// *)) - val (path, rest) = Substring.splitl (fn c => c <> #"?" orelse c <> #"#") (Substring.triml 1 rest (* / *)) - val (query, rest) = if Substring.first rest = SOME #"?" - then Substring.splitl (fn c => c <> #"#") (Substring.triml 1 rest (* ? *)) - else (Substring.full "", rest) - val fragment = if Substring.first rest = SOME #"#" - then (Substring.triml 1 rest (* # *)) - else Substring.full "" - - in - { scheme = Substring.string scheme - , authority = Substring.string authority - , path = Substring.string path - , query = Substring.string query - , fragment = Substring.string fragment - } - end - -type position = { line: int - , character: int - } -fun parsePosition (j: Json.json) = - { line = parseInt (getJsonObjectValue' "line" j) - , character = parseInt (getJsonObjectValue' "character" j) - } - -datatype result = Success of Json.json - | Error of (int * string) - -fun handleHover (params: Json.json): result = - let - val textDocument = parseTextDocumentIdentifier (getJsonObjectValue' "textDocument" params) - val position = parsePosition (getJsonObjectValue' "position" params) - val answer = "" - in - Success (Json.Obj (("contents", Json.String answer) :: [])) - end - -fun serverLoop () = +(* 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 + val line = TextIO.inputLine TextIO.stdIn + 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 + end + + fun readAllHeaders (): (string * string) list = + let + fun doReadAllHeaders (l: (string * string) list): (string * string) list = + case readHeader () of + NONE => l + | SOME tup => tup :: doReadAllHeaders l + + in + doReadAllHeaders [] + end + + fun parseBasicRequest (j: Json.json): {id: Json.json, method: string, params: Json.json} = + let + val id = FromJson.get "id" j + val method = FromJson.asString (FromJson.get "method" j) + val params = FromJson.get "params" j + in + {id = id, method = method, params = params} + end + + type textDocumentIdentifier = + { scheme: string + , authority: string + , path: string + , query: string + , fragment: string + } + fun parseTextDocumentIdentifier (j: Json.json): textDocumentIdentifier = + let + val str = Substring.full (FromJson.asString (FromJson.get "uri" j)) + val (scheme, rest) = Substring.splitl (fn c => c <> #":") str + val (authority, rest) = Substring.splitl (fn c => c <> #"/") (Substring.triml 3 rest (* :// *)) + val (path, rest) = Substring.splitl (fn c => c <> #"?" orelse c <> #"#") (Substring.triml 1 rest (* / *)) + val (query, rest) = if Substring.first rest = SOME #"?" + then Substring.splitl (fn c => c <> #"#") (Substring.triml 1 rest (* ? *)) + else (Substring.full "", rest) + val fragment = if Substring.first rest = SOME #"#" + then (Substring.triml 1 rest (* # *)) + else Substring.full "" + + in + { scheme = Substring.string scheme + , authority = Substring.string authority + , path = Substring.string path + , query = Substring.string query + , fragment = Substring.string fragment + } + end + + type position = { line: int + , character: int + } + fun parsePosition (j: Json.json) = + { line = FromJson.asInt (FromJson.get "line" j) + , character = FromJson.asInt (FromJson.get "character" j) + } + + + fun readRequestFromStdIO (): {id: Json.json, method: string, params: Json.json} = + let + val headers = readAllHeaders () + val lengthO = List.find (fn (k,v) => k = "Content-Length") headers + val request = case lengthO of + NONE => raise Fail "No header with Content-Length found" + | SOME (k, v) => + case Int.fromString v of + NONE => raise Fail ("Couldn't parse content-length from string: " ^ v) + | SOME i => TextIO.inputN (TextIO.stdIn, i) + val parsed = Json.parse request + in + parseBasicRequest parsed + end + + fun parseHoverReq (params: Json.json): { textDocument: textDocumentIdentifier , position: position } = + { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" params) + , position = parsePosition (FromJson.get "position" params) + } + + fun printHoverResponse (resp: {contents: string}): Json.json = + Json.Obj (("contents", Json.String (#contents resp)) :: []) + + datatype 'a result = + Success of 'a + | Error of (int * string) + + fun mapResult (f: 'a -> 'b) (a: 'a result): 'b result = + case a of + Success contents => Success (f contents) + | Error e => Error e + type handlers = + { initialize: unit -> { capabilities: {hoverProvider: bool}} result + , shutdown: unit -> unit result + , textDocument_hover: { textDocument: textDocumentIdentifier + , position: position } + -> {contents: string} result + } + + fun handleRequest + (requestMessage: {id: Json.json, method: string, params: Json.json}) + (handlers: handlers) + : unit = let - val headers = readAllHeaders [] - val lengthO = List.find (fn (k,v) => k = "Content-Length") headers - val request = case lengthO of - NONE => raise Fail "No header with Content-Length found" - | SOME (k, v) => - case Int.fromString v of - NONE => raise Fail ("Couldn't parse content-length from string: " ^ v) - | SOME i => TextIO.inputN (TextIO.stdIn, i) - (* val parsed = Json.parse (Substring.string (Substring.trimr 1 (Substring.full request))) (* Trimming last newline *) *) - val parsed = Json.parse request - val requestMessage = parseRequest parsed - fun fail (err: (int * string)) = - Json.print (Json.Obj (("id", #id requestMessage) - :: ("error", Json.Obj (("code", Json.Int (#1 err)) - :: ("message", Json.String (#2 err)) - :: [])) - :: [] - )) - val result: result = + val result: Json.json result = case #method requestMessage of - "initialize" => Success (Json.Obj (("capabilities", Json.Obj (("hoverProvider", Json.Bool true) :: [])) :: [])) - | "textDocument/hover" => handleHover (#params requestMessage) - | "shutdown" => Success (Json.Null) - | "exit" => OS.Process.exit OS.Process.success + "initialize" => + mapResult + (fn res => Json.Obj (("capabilities", Json.Obj (("hoverProvider", Json.Bool (#hoverProvider (#capabilities res))) + :: [])) + :: [])) + ((#initialize handlers) ()) + | "textDocument/hover" => + mapResult + printHoverResponse + ((#textDocument_hover handlers) + (parseHoverReq (#params requestMessage))) + | "shutdown" => + mapResult + (fn () => Json.Null) + ((#shutdown handlers) ()) + | "exit" => + OS.Process.exit OS.Process.success | method => Error (~32601, "Method not supported: " ^ method) in case result of @@ -152,8 +205,22 @@ fun serverLoop () = :: [] ))) end + +end + +structure Lsp :> LSP = struct + +fun serverLoop () = + let + val requestMessage = LspSpec.readRequestFromStdIO () + in + LspSpec.handleRequest + requestMessage + { initialize = fn () => LspSpec.Success {capabilities = {hoverProvider = true}} + , shutdown = fn () => LspSpec.Success () + , textDocument_hover = fn _ => LspSpec.Success {contents = ""} + } + end -fun startServer () = - while (1 < 2) do - serverLoop () +fun startServer () = while true do serverLoop () end -- cgit v1.2.3