summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Simon Van Casteren <simon.van.casteren@gmail.com>2019-12-09 14:45:37 +0100
committerGravatar Simon Van Casteren <simonvancasteren@localhost.localdomain>2019-12-13 11:46:57 +0100
commit1953cd47c6abdec2437c833cb8e26cf1e8ac1834 (patch)
treeadc917187b8affce069c7c208723944d4f8b23da /src
parent26e16f90067ee294d1ccd6341547dbae585cdb3e (diff)
First actually working version of LSP
Diffstat (limited to 'src')
-rw-r--r--src/json.sml11
-rw-r--r--src/lsp.sml187
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 ()