From be644b0be6acd3cdeb957d46e9477ea3e16599ba Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Fri, 13 Dec 2019 11:32:02 +0100 Subject: Moved json and lsp code into seperate modules --- src/fromjson.sig | 8 + src/fromjson.sml | 35 ++++ src/lsp.sml | 537 ++----------------------------------------------------- src/lspspec.sml | 447 +++++++++++++++++++++++++++++++++++++++++++++ src/sources | 5 + 5 files changed, 506 insertions(+), 526 deletions(-) create mode 100644 src/fromjson.sig create mode 100644 src/fromjson.sml create mode 100644 src/lspspec.sml diff --git a/src/fromjson.sig b/src/fromjson.sig new file mode 100644 index 00000000..3fdc1a89 --- /dev/null +++ b/src/fromjson.sig @@ -0,0 +1,8 @@ +signature FROMJSON = sig + val getO: string -> Json.json -> Json.json option + val get: string -> Json.json -> Json.json + val asInt: Json.json -> int + val asString: Json.json -> string + val asOptionalInt: Json.json -> int option + val asOptionalString: Json.json -> string option +end diff --git a/src/fromjson.sml b/src/fromjson.sml new file mode 100644 index 00000000..6a9bd71b --- /dev/null +++ b/src/fromjson.sml @@ -0,0 +1,35 @@ +structure FromJson :> FROMJSON = struct +fun getO (s: string) (l: Json.json): Json.json option = + case l of + Json.Obj pairs => + (case List.find (fn tup => #1 tup = s) pairs of + NONE => NONE + | SOME tup => SOME (#2 tup)) + | _ => raise Fail ("Expected JSON object, got: " ^ Json.print l) +fun get (s: string) (l: Json.json): Json.json = + (case getO s l of + NONE => raise Fail ("Failed to find JSON object key " ^ s ^ " in " ^ Json.print l) + | SOME a => a) + +fun asInt (j: Json.json): int = + case j of + Json.Int i => i + | _ => raise Fail ("Expected JSON int, got: " ^ Json.print j) + +fun asString (j: Json.json): string = + case j of + Json.String s => s + | _ => raise Fail ("Expected JSON string, got: " ^ Json.print j) + +fun asOptionalInt (j: Json.json): int option = + case j of + Json.Null => NONE + | Json.Int i => SOME i + | _ => raise Fail ("Expected JSON int or null, got: " ^ Json.print j) + +fun asOptionalString (j: Json.json): string option = + case j of + Json.Null => NONE + | Json.String s => SOME s + | _ => raise Fail ("Expected JSON string or null, got: " ^ Json.print j) +end diff --git a/src/lsp.sml b/src/lsp.sml index 920f9f35..d902fed4 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -1,519 +1,8 @@ structure C = Compiler -fun debug (str: string): unit = - (TextIO.output (TextIO.stdErr, str ^ "\n\n"); TextIO.flushOut TextIO.stdErr) - -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) - -fun joinStr (sep: string) (strs: string list): string = - List.foldl (fn (str, acc) => if acc = "" then str else acc ^ sep ^ str) "" strs - -structure FromJson = struct -fun getO (s: string) (l: Json.json): Json.json option = - case l of - Json.Obj pairs => - (case List.find (fn tup => #1 tup = s) pairs of - NONE => NONE - | SOME tup => SOME (#2 tup)) - | _ => raise Fail ("Expected JSON object, got: " ^ Json.print l) -fun get (s: string) (l: Json.json): Json.json = - (case getO s l of - NONE => raise Fail ("Failed to find JSON object key " ^ s ^ " in " ^ Json.print l) - | SOME a => a) - -fun asInt (j: Json.json): int = - case j of - Json.Int i => i - | _ => raise Fail ("Expected JSON int, got: " ^ Json.print j) - -fun asString (j: Json.json): string = - case j of - Json.String s => s - | _ => raise Fail ("Expected JSON string, got: " ^ Json.print j) - -fun asOptionalInt (j: Json.json): int option = - case j of - Json.Null => NONE - | Json.Int i => SOME i - | _ => raise Fail ("Expected JSON int or null, got: " ^ Json.print j) - -fun asOptionalString (j: Json.json): string option = - case j of - Json.Null => NONE - | Json.String s => SOME s - | _ => raise Fail ("Expected JSON string or null, got: " ^ Json.print j) -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 => - 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 = - let - fun doReadAllHeaders (l: (string * string) list): (string * string) list = - case readHeader () of - NONE => l - | SOME tup => tup :: doReadAllHeaders l - - in - doReadAllHeaders [] - end - 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 = SOME (FromJson.get "id" j) - handle ex => NONE - val method = FromJson.asString (FromJson.get "method" j) - val params = FromJson.get "params" j - in - case id of - NONE => Notification {method = method, params = params} - | SOME id => RequestMessage {id = id, method = method, params = params} - end - - type documentUri = - { scheme: string - , authority: string - , path: string - , query: string - , fragment: string - } - fun parseDocumentUri (str: string): documentUri = - let - val str = Substring.full str - 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 <> #"#") 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 - fun printDocumentUri (d: documentUri) = - (#scheme d) ^ "://" ^ - (#authority d) ^ - (#path d) ^ - (if #query d <> "" then "?" ^ #query d else "") ^ - (if #fragment d <> "" then "#" ^ #fragment d else "") - - type textDocumentIdentifier = { uri: documentUri} - fun parseTextDocumentIdentifier (j: Json.json): textDocumentIdentifier = - { uri = parseDocumentUri (FromJson.asString (FromJson.get "uri" j))} - - type versionedTextDocumentIdentifier = - { uri: documentUri - , version: int option - } - fun parseVersionedTextDocumentIdentifier (j: Json.json): versionedTextDocumentIdentifier = - { uri = parseDocumentUri (FromJson.asString (FromJson.get "uri" j)) - , version = FromJson.asOptionalInt (FromJson.get "version" j) - } - - type textDocumentItem = { - uri: documentUri, - languageId: string, - version: int, (* The version number of this document (it will increase after each change, including undo/redo). *) - text: string - } - fun parseTextDocumentItem (j: Json.json) = - { uri = parseDocumentUri (FromJson.asString (FromJson.get "uri" j)) - , languageId = FromJson.asString (FromJson.get "languageId" j) - , version = FromJson.asInt (FromJson.get "version" j) - , text = FromJson.asString (FromJson.get "text" j) - } - - 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 printPosition (p: position): Json.json = Json.Obj [ ("line", Json.Int (#line p)) - , ("character", Json.Int (#character p))] - - type range = { start: position - , end_: position } - fun parseRange (j: Json.json): range = - { start = parsePosition (FromJson.get "start" j) - , end_ = parsePosition (FromJson.get "end" j) - } - fun printRange (r: range): Json.json = Json.Obj [ ("start", printPosition (#start r)) - , ("end", printPosition (#end_ r))] - - fun readRequestFromStdIO (): message = - 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 - parseMessage parsed - end - - type hoverReq = { textDocument: textDocumentIdentifier , position: position } - type hoverResp = {contents: string} option - fun parseHoverReq (params: Json.json): hoverReq = - { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" params) - , position = parsePosition (FromJson.get "position" params) - } - fun printHoverResponse (resp: hoverResp): Json.json = - case resp of - NONE => Json.Null - | SOME obj => Json.Obj [("contents", Json.String (#contents obj))] - - type didOpenParams = { textDocument: textDocumentItem } - fun parseDidOpenParams (params: Json.json): didOpenParams = - { textDocument = parseTextDocumentItem (FromJson.get "textDocument" params) } - - type contentChange = { range: range option - , rangeLength: int option - , text: string } - type didChangeParams = - { textDocument: versionedTextDocumentIdentifier - , contentChanges: contentChange list - } - fun parseDidChangeParams (params: Json.json): didChangeParams = - { textDocument = parseVersionedTextDocumentIdentifier (FromJson.get "textDocument" params) - , contentChanges = case FromJson.get "contentChanges" params of - Json.Array js => - List.map (fn j => { range = Option.map parseRange (FromJson.getO "range" j) - , rangeLength = Option.map FromJson.asInt (FromJson.getO "rangeLength" j) - , text = FromJson.asString (FromJson.get "text" j) - } - ) js - | j => raise Fail ("Expected JSON array, got: " ^ Json.print j) - } - - type didSaveParams = { textDocument: textDocumentIdentifier } - fun parseDidSaveParams (params: Json.json): didSaveParams = - { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" params) - (* , text = ... *) - } - type didCloseParams = { textDocument: textDocumentIdentifier } - fun parseDidCloseParams (params: Json.json): didCloseParams = - { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" params) - } - type initializeParams = - { rootUri: documentUri option } - fun parseInitializeParams (j: Json.json) = - { rootUri = - Option.map - parseDocumentUri - (FromJson.asOptionalString (FromJson.get "rootUri" j)) - } - type diagnostic = { range: range - (* code?: number | string *) - , severity: int (* 1 = error, 2 = warning, 3 = info, 4 = hint*) - , source: string - , message: string - (* relatedInformation?: DiagnosticRelatedInformation[]; *) - } - fun printDiagnostic (d: diagnostic): Json.json = - Json.Obj [ ("range", printRange (#range d)) - , ("severity", Json.Int (#severity d)) - , ("source", Json.String (#source d)) - , ("message", Json.String (#message d)) - ] - type publishDiagnosticsParams = { uri: documentUri - , diagnostics: diagnostic list - } - fun printPublishDiagnosticsParams (p: publishDiagnosticsParams): Json.json = - Json.Obj [ ("uri", Json.String (printDocumentUri (#uri p))) - , ("diagnostics", Json.Array (List.map printDiagnostic (#diagnostics p)))] - - type completionReq = - { textDocument: textDocumentIdentifier - , position: position - , context: { triggerCharacter: string option - , triggerKind: int (* 1 = Invoked = typing an identifier or manual invocation or API - 2 = TriggerCharacter - 3 = TriggerForIncompleteCompletions*)} option - } - fun parseCompletionReq (j: Json.json): completionReq = - { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" j) - , position = parsePosition (FromJson.get "position" j) - , context = case FromJson.getO "context" j of - NONE => NONE - | SOME ctx => SOME { triggerCharacter = Option.map FromJson.asString (FromJson.getO "triggerCharacter" ctx) - , triggerKind = FromJson.asInt (FromJson.get "triggerKind" ctx) - } - } - - datatype completionItemKind = Text | Method | Function | Constructor | Field | Variable | Class | Interface | Module | Property | Unit | Value | Enum | Keyword | Snippet | Color | File | Reference | Folder | EnumMember | Constant | Struct | Event | Operator | TypeParameter - fun completionItemKindToInt (a: completionItemKind) = - case a of - Text => 1 - | Method => 2 - | Function => 3 - | Constructor => 4 - | Field => 5 - | Variable => 6 - | Class => 7 - | Interface => 8 - | Module => 9 - | Property => 10 - | Unit => 11 - | Value => 12 - | Enum => 13 - | Keyword => 14 - | Snippet => 15 - | Color => 16 - | File => 17 - | Reference => 18 - | Folder => 19 - | EnumMember => 20 - | Constant => 21 - | Struct => 22 - | Event => 23 - | Operator => 24 - | TypeParameter => 25 - - type completionItem = { label: string - , kind: completionItemKind - , detail: string - } - type completionResp = { isIncomplete: bool - , items: completionItem list - } - - fun printCompletionItem (a: completionItem): Json.json = - Json.Obj [ ("label", Json.String (#label a)) - , ("kind", Json.Int (completionItemKindToInt (#kind a))) - , ("detail", Json.String (#detail a)) - ] - fun printCompletionResp (a: completionResp): Json.json = - Json.Obj [ ("isIncomplete", Json.Bool (#isIncomplete a)) - , (("items", Json.Array (List.map printCompletionItem (#items a))))] - - type initializeResponse = { capabilities: - { hoverProvider: bool - , completionProvider: {triggerCharacters: string list} option - , textDocumentSync: - { openClose: bool - , change: int (* 0 = None, 1 = Full, 2 = Incremental *) - , save: { includeText: bool } option - } - }} - fun printInitializeResponse (res: initializeResponse) = - Json.Obj [("capabilities", - let - val capabilities = #capabilities res - in - Json.Obj [ ("hoverProvider", Json.Bool (#hoverProvider capabilities)) - , ("completionProvider", case #completionProvider capabilities of - NONE => Json.Null - | SOME cp => Json.Obj [("triggerCharacters", Json.Array (List.map Json.String (#triggerCharacters cp)))] - ) - , ("textDocumentSync", - let - val textDocumentSync = #textDocumentSync capabilities - in - Json.Obj [ ("openClose", Json.Bool (#openClose textDocumentSync )) - , ("change", Json.Int (#change textDocumentSync)) - , ("save", case #save textDocumentSync of - NONE => Json.Null - | SOME save => Json.Obj [("includeText", Json.Bool (#includeText save) )])] - end - )] - end - )] - - 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 toclient = { showMessage: string -> int -> unit - , publishDiagnostics: publishDiagnosticsParams -> unit } - type messageHandlers = - { initialize: initializeParams -> initializeResponse result - , shutdown: unit -> unit result - , textDocument_hover: toclient -> hoverReq -> hoverResp result - , textDocument_completion: completionReq -> completionResp result - } - - fun showMessage str typ = - let - val jsonToPrint = Json.print (Json.Obj [ ("jsonrpc", Json.String "2.0") - , ("method", Json.String "window/showMessage") - , ("params", Json.Obj [ ("type", Json.Int typ) - , ("message", Json.String str)]) - ]) - val toPrint = "Content-Length:" ^ Int.toString (String.size jsonToPrint) ^ "\r\n\r\n" ^ jsonToPrint - in - TextIO.print toPrint - end - fun publishDiagnostics diags = - let - val jsonToPrint = Json.print ((Json.Obj [ ("jsonrpc", Json.String "2.0") - , ("method", Json.String "textDocument/publishDiagnostics") - , ("params", printPublishDiagnosticsParams diags) - ])) - val toPrint = "Content-Length:" ^ Int.toString (String.size jsonToPrint) ^ "\r\n\r\n" ^ jsonToPrint - in - TextIO.print toPrint - end - val toclient: toclient = {showMessage = showMessage, publishDiagnostics = publishDiagnostics} - - fun handleMessage - (requestMessage: {id: Json.json, method: string, params: Json.json}) - (handlers: messageHandlers) - : unit = - let - val result: Json.json result = - case #method requestMessage of - "initialize" => - mapResult - printInitializeResponse - ((#initialize handlers) - (parseInitializeParams (#params requestMessage))) - | "textDocument/hover" => - mapResult - printHoverResponse - ((#textDocument_hover handlers) - toclient - (parseHoverReq (#params requestMessage))) - | "textDocument/completion" => - mapResult - printCompletionResp - ((#textDocument_completion handlers) - (parseCompletionReq (#params requestMessage))) - | "shutdown" => - mapResult - (fn () => Json.Null) - ((#shutdown handlers) ()) - | "exit" => - OS.Process.exit OS.Process.success - | method => (debug ("Method not supported: " ^ 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 => - 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) => - 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 - , textDocument_didOpen: toclient -> didOpenParams -> unit - , textDocument_didChange: toclient -> didChangeParams -> unit - , textDocument_didSave: toclient -> didSaveParams -> unit - , textDocument_didClose: toclient -> didCloseParams -> unit - } - fun handleNotification - (notification: {method: string, params: Json.json}) - (handlers: notificationHandlers) - = - case #method notification of - "initialized" => (#initialized handlers) () - | "textDocument/didOpen" => (#textDocument_didOpen handlers) toclient (parseDidOpenParams (#params notification)) - | "textDocument/didChange" => (#textDocument_didChange handlers) toclient (parseDidChangeParams (#params notification)) - | "textDocument/didSave" => (#textDocument_didSave handlers) toclient (parseDidSaveParams (#params notification)) - | "textDocument/didClose" => (#textDocument_didClose handlers) toclient (parseDidCloseParams (#params notification)) - | m => debug ("Notification method not supported: " ^ m) - -end structure Lsp :> LSP = struct - -datatype lspError = InternalError of string -exception LspError of lspError -fun handleLspErrorInNotification (e: lspError) : unit = - let - fun print (message: string) = - let - val jsonStr = Json.print (Json.Obj [ ("jsonrpc", Json.String "2.0") - , ("method", Json.String "window/showMessage") - , ("params", Json.Obj [ ("type", Json.Int 1 (* Error*)) - , ("message", Json.String message)]) - ]) - in - TextIO.print ("Content-Length:" ^ Int.toString (String.size jsonStr) ^ "\r\n\r\n" ^ jsonStr) - end - in - case e of - InternalError str => print str - end -fun handleLspErrorInRequest (id: Json.json) (e: lspError): unit = - let - fun print (code: int) (message: string) = - let - val jsonStr = Json.print (Json.Obj [ ("jsonrpc", Json.String "2.0") - , ("id", id) - , ("error", Json.Obj [ ("code", Json.Int code (* Error*)) - , ("message", Json.String message)]) - ]) - in - TextIO.print ("Content-Length:" ^ Int.toString (String.size jsonStr) ^ "\r\n\r\n" ^ jsonStr) - end - in - case e of - InternalError str => print (~32603) str - end +val debug = LspSpec.debug structure SK = struct type ord_key = string @@ -614,7 +103,7 @@ fun elabFile (state: state) (fileName: string): ({ decls: Elab.decl list, envBef val () = Elaborate.incremental := true (* Parsing .urp *) val job = case C.run (C.transform C.parseUrp "parseUrp") (#urpPath state) of - NONE => raise LspError (InternalError ("Couldn't parse .urp file at " ^ (#urpPath state))) + NONE => raise LspSpec.LspError (LspSpec.InternalError ("Couldn't parse .urp file at " ^ (#urpPath state))) | SOME a => a val moduleSearchRes = List.foldl @@ -629,7 +118,7 @@ fun elabFile (state: state) (fileName: string): ({ decls: Elab.decl list, envBef val modulesBeforeThisFile = #1 moduleSearchRes val () = if #2 moduleSearchRes then () - else raise LspError (InternalError ("Couldn't find file " ^ fileName ^ " referenced in .urp file at " ^ (#urpPath state))) + else raise LspSpec.LspError (LspSpec.InternalError ("Couldn't find file " ^ fileName ^ " referenced in .urp file at " ^ (#urpPath state))) (* Parsing .urs files of previous modules *) val parsedUrss = List.map (fn entry => let @@ -639,9 +128,9 @@ fun elabFile (state: state) (fileName: string): ({ decls: Elab.decl list, envBef , parsed = if OS.FileSys.access (fileName, []) then case C.run (C.transform C.parseUrs "parseUrs") fileName of - NONE => raise LspError (InternalError ("Failed to parse .urs file at " ^ fileName)) + NONE => raise LspSpec.LspError (LspSpec.InternalError ("Failed to parse .urs file at " ^ fileName)) | SOME a => a - else raise LspError (InternalError ("Couldn't find an .urs file for " ^ fileName)) + else raise LspSpec.LspError (LspSpec.InternalError ("Couldn't find an .urs file for " ^ fileName)) } end) modulesBeforeThisFile @@ -655,15 +144,15 @@ fun elabFile (state: state) (fileName: string): ({ decls: Elab.decl list, envBef val parsedBasisUrs = case C.run (C.transform C.parseUrs "parseUrs") basisF of - NONE => raise LspError (InternalError ("Failed to parse basis.urs file at " ^ basisF)) + NONE => raise LspSpec.LspError (LspSpec.InternalError ("Failed to parse basis.urs file at " ^ basisF)) | SOME a => a val parsedTopUrs = case C.run (C.transform C.parseUrs "parseUrs") topF of - NONE => raise LspError (InternalError ("Failed to parse top.urs file at " ^ topF)) + NONE => raise LspSpec.LspError (LspSpec.InternalError ("Failed to parse top.urs file at " ^ topF)) | SOME a => a val parsedTopUr = case C.run (C.transform C.parseUr "parseUr") topF' of - NONE => raise LspError (InternalError ("Failed to parse top.ur file at " ^ topF')) + NONE => raise LspSpec.LspError (LspSpec.InternalError ("Failed to parse top.ur file at " ^ topF')) | SOME a => a (* Parsing .ur and .urs of current file *) @@ -1031,10 +520,10 @@ fun handleDocumentDidClose (state: state) (toclient: LspSpec.toclient) (p: LspSp fun serverLoop () = let + val state = !stateRef val requestMessage = LspSpec.readRequestFromStdIO () handle ex => (debug (General.exnMessage ex) ; raise ex) - val state = !stateRef in case state of NONE => @@ -1065,7 +554,7 @@ fun serverLoop () = | SOME state => (case requestMessage of LspSpec.Notification n => - ((LspSpec.handleNotification + (LspSpec.handleNotification n { initialized = fn () => () , textDocument_didOpen = fn toclient => fn p => handleDocumentSavedOrOpened state toclient (#uri (#textDocument p)) (SOME (#text (#textDocument p))) @@ -1073,19 +562,15 @@ fun serverLoop () = , textDocument_didSave = fn toclient => fn p => handleDocumentSavedOrOpened state toclient (#uri (#textDocument p)) NONE , textDocument_didClose = fn toclient => fn p => handleDocumentDidClose state toclient p }) - handle LspError e => handleLspErrorInNotification e - | ex => handleLspErrorInNotification (InternalError (General.exnMessage ex))) | LspSpec.RequestMessage m => (* TODO should error handling here be inside handleMessage? *) - ((LspSpec.handleMessage + (LspSpec.handleMessage m { initialize = fn _ => LspSpec.Error (~32600, "Server already initialized") , shutdown = fn () => LspSpec.Success () , textDocument_hover = fn toclient => handleHover state , textDocument_completion = handleCompletion state }) - handle LspError e => handleLspErrorInRequest (#id m) e - | ex => handleLspErrorInRequest (#id m) (InternalError (General.exnMessage ex))) ) end diff --git a/src/lspspec.sml b/src/lspspec.sml new file mode 100644 index 00000000..7993038e --- /dev/null +++ b/src/lspspec.sml @@ -0,0 +1,447 @@ +structure LspSpec = struct + + datatype lspError = InternalError of string + exception LspError of lspError + + fun debug (str: string): unit = + (TextIO.output (TextIO.stdErr, str ^ "\n\n"); TextIO.flushOut TextIO.stdErr) + + 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) + + 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 => + 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 = + let + fun doReadAllHeaders (l: (string * string) list): (string * string) list = + case readHeader () of + NONE => l + | SOME tup => tup :: doReadAllHeaders l + + in + doReadAllHeaders [] + end + 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 = SOME (FromJson.get "id" j) + handle ex => NONE + val method = FromJson.asString (FromJson.get "method" j) + val params = FromJson.get "params" j + in + case id of + NONE => Notification {method = method, params = params} + | SOME id => RequestMessage {id = id, method = method, params = params} + end + + type documentUri = + { scheme: string + , authority: string + , path: string + , query: string + , fragment: string + } + fun parseDocumentUri (str: string): documentUri = + let + val str = Substring.full str + 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 <> #"#") 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 + fun printDocumentUri (d: documentUri) = + (#scheme d) ^ "://" ^ + (#authority d) ^ + (#path d) ^ + (if #query d <> "" then "?" ^ #query d else "") ^ + (if #fragment d <> "" then "#" ^ #fragment d else "") + + type textDocumentIdentifier = { uri: documentUri} + fun parseTextDocumentIdentifier (j: Json.json): textDocumentIdentifier = + { uri = parseDocumentUri (FromJson.asString (FromJson.get "uri" j))} + + type versionedTextDocumentIdentifier = + { uri: documentUri + , version: int option + } + fun parseVersionedTextDocumentIdentifier (j: Json.json): versionedTextDocumentIdentifier = + { uri = parseDocumentUri (FromJson.asString (FromJson.get "uri" j)) + , version = FromJson.asOptionalInt (FromJson.get "version" j) + } + + type textDocumentItem = { + uri: documentUri, + languageId: string, + version: int, (* The version number of this document (it will increase after each change, including undo/redo). *) + text: string + } + fun parseTextDocumentItem (j: Json.json) = + { uri = parseDocumentUri (FromJson.asString (FromJson.get "uri" j)) + , languageId = FromJson.asString (FromJson.get "languageId" j) + , version = FromJson.asInt (FromJson.get "version" j) + , text = FromJson.asString (FromJson.get "text" j) + } + + 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 printPosition (p: position): Json.json = Json.Obj [ ("line", Json.Int (#line p)) + , ("character", Json.Int (#character p))] + + type range = { start: position + , end_: position } + fun parseRange (j: Json.json): range = + { start = parsePosition (FromJson.get "start" j) + , end_ = parsePosition (FromJson.get "end" j) + } + fun printRange (r: range): Json.json = Json.Obj [ ("start", printPosition (#start r)) + , ("end", printPosition (#end_ r))] + + fun readRequestFromStdIO (): message = + 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 + parseMessage parsed + end + + type hoverReq = { textDocument: textDocumentIdentifier , position: position } + type hoverResp = {contents: string} option + fun parseHoverReq (params: Json.json): hoverReq = + { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" params) + , position = parsePosition (FromJson.get "position" params) + } + fun printHoverResponse (resp: hoverResp): Json.json = + case resp of + NONE => Json.Null + | SOME obj => Json.Obj [("contents", Json.String (#contents obj))] + + type didOpenParams = { textDocument: textDocumentItem } + fun parseDidOpenParams (params: Json.json): didOpenParams = + { textDocument = parseTextDocumentItem (FromJson.get "textDocument" params) } + + type contentChange = { range: range option + , rangeLength: int option + , text: string } + type didChangeParams = + { textDocument: versionedTextDocumentIdentifier + , contentChanges: contentChange list + } + fun parseDidChangeParams (params: Json.json): didChangeParams = + { textDocument = parseVersionedTextDocumentIdentifier (FromJson.get "textDocument" params) + , contentChanges = case FromJson.get "contentChanges" params of + Json.Array js => + List.map (fn j => { range = Option.map parseRange (FromJson.getO "range" j) + , rangeLength = Option.map FromJson.asInt (FromJson.getO "rangeLength" j) + , text = FromJson.asString (FromJson.get "text" j) + } + ) js + | j => raise Fail ("Expected JSON array, got: " ^ Json.print j) + } + + type didSaveParams = { textDocument: textDocumentIdentifier } + fun parseDidSaveParams (params: Json.json): didSaveParams = + { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" params) + (* , text = ... *) + } + type didCloseParams = { textDocument: textDocumentIdentifier } + fun parseDidCloseParams (params: Json.json): didCloseParams = + { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" params) + } + type initializeParams = + { rootUri: documentUri option } + fun parseInitializeParams (j: Json.json) = + { rootUri = + Option.map + parseDocumentUri + (FromJson.asOptionalString (FromJson.get "rootUri" j)) + } + type diagnostic = { range: range + (* code?: number | string *) + , severity: int (* 1 = error, 2 = warning, 3 = info, 4 = hint*) + , source: string + , message: string + (* relatedInformation?: DiagnosticRelatedInformation[]; *) + } + fun printDiagnostic (d: diagnostic): Json.json = + Json.Obj [ ("range", printRange (#range d)) + , ("severity", Json.Int (#severity d)) + , ("source", Json.String (#source d)) + , ("message", Json.String (#message d)) + ] + type publishDiagnosticsParams = { uri: documentUri + , diagnostics: diagnostic list + } + fun printPublishDiagnosticsParams (p: publishDiagnosticsParams): Json.json = + Json.Obj [ ("uri", Json.String (printDocumentUri (#uri p))) + , ("diagnostics", Json.Array (List.map printDiagnostic (#diagnostics p)))] + + type completionReq = + { textDocument: textDocumentIdentifier + , position: position + , context: { triggerCharacter: string option + , triggerKind: int (* 1 = Invoked = typing an identifier or manual invocation or API + 2 = TriggerCharacter + 3 = TriggerForIncompleteCompletions*)} option + } + fun parseCompletionReq (j: Json.json): completionReq = + { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" j) + , position = parsePosition (FromJson.get "position" j) + , context = case FromJson.getO "context" j of + NONE => NONE + | SOME ctx => SOME { triggerCharacter = Option.map FromJson.asString (FromJson.getO "triggerCharacter" ctx) + , triggerKind = FromJson.asInt (FromJson.get "triggerKind" ctx) + } + } + + datatype completionItemKind = Text | Method | Function | Constructor | Field | Variable | Class | Interface | Module | Property | Unit | Value | Enum | Keyword | Snippet | Color | File | Reference | Folder | EnumMember | Constant | Struct | Event | Operator | TypeParameter + fun completionItemKindToInt (a: completionItemKind) = + case a of + Text => 1 + | Method => 2 + | Function => 3 + | Constructor => 4 + | Field => 5 + | Variable => 6 + | Class => 7 + | Interface => 8 + | Module => 9 + | Property => 10 + | Unit => 11 + | Value => 12 + | Enum => 13 + | Keyword => 14 + | Snippet => 15 + | Color => 16 + | File => 17 + | Reference => 18 + | Folder => 19 + | EnumMember => 20 + | Constant => 21 + | Struct => 22 + | Event => 23 + | Operator => 24 + | TypeParameter => 25 + + type completionItem = { label: string + , kind: completionItemKind + , detail: string + } + type completionResp = { isIncomplete: bool + , items: completionItem list + } + + fun printCompletionItem (a: completionItem): Json.json = + Json.Obj [ ("label", Json.String (#label a)) + , ("kind", Json.Int (completionItemKindToInt (#kind a))) + , ("detail", Json.String (#detail a)) + ] + fun printCompletionResp (a: completionResp): Json.json = + Json.Obj [ ("isIncomplete", Json.Bool (#isIncomplete a)) + , (("items", Json.Array (List.map printCompletionItem (#items a))))] + + type initializeResponse = { capabilities: + { hoverProvider: bool + , completionProvider: {triggerCharacters: string list} option + , textDocumentSync: + { openClose: bool + , change: int (* 0 = None, 1 = Full, 2 = Incremental *) + , save: { includeText: bool } option + } + }} + fun printInitializeResponse (res: initializeResponse) = + Json.Obj [("capabilities", + let + val capabilities = #capabilities res + in + Json.Obj [ ("hoverProvider", Json.Bool (#hoverProvider capabilities)) + , ("completionProvider", case #completionProvider capabilities of + NONE => Json.Null + | SOME cp => Json.Obj [("triggerCharacters", Json.Array (List.map Json.String (#triggerCharacters cp)))] + ) + , ("textDocumentSync", + let + val textDocumentSync = #textDocumentSync capabilities + in + Json.Obj [ ("openClose", Json.Bool (#openClose textDocumentSync )) + , ("change", Json.Int (#change textDocumentSync)) + , ("save", case #save textDocumentSync of + NONE => Json.Null + | SOME save => Json.Obj [("includeText", Json.Bool (#includeText save) )])] + end + )] + end + )] + + 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 toclient = { showMessage: string -> int -> unit + , publishDiagnostics: publishDiagnosticsParams -> unit } + type messageHandlers = + { initialize: initializeParams -> initializeResponse result + , shutdown: unit -> unit result + , textDocument_hover: toclient -> hoverReq -> hoverResp result + , textDocument_completion: completionReq -> completionResp result + } + + fun showMessage str typ = + let + val jsonToPrint = Json.print (Json.Obj [ ("jsonrpc", Json.String "2.0") + , ("method", Json.String "window/showMessage") + , ("params", Json.Obj [ ("type", Json.Int typ) + , ("message", Json.String str)]) + ]) + val toPrint = "Content-Length:" ^ Int.toString (String.size jsonToPrint) ^ "\r\n\r\n" ^ jsonToPrint + in + TextIO.print toPrint + end + fun publishDiagnostics diags = + let + val jsonToPrint = Json.print ((Json.Obj [ ("jsonrpc", Json.String "2.0") + , ("method", Json.String "textDocument/publishDiagnostics") + , ("params", printPublishDiagnosticsParams diags) + ])) + val toPrint = "Content-Length:" ^ Int.toString (String.size jsonToPrint) ^ "\r\n\r\n" ^ jsonToPrint + in + TextIO.print toPrint + end + val toclient: toclient = {showMessage = showMessage, publishDiagnostics = publishDiagnostics} + + fun handleMessage + (requestMessage: {id: Json.json, method: string, params: Json.json}) + (handlers: messageHandlers) + : unit = + let + val result: Json.json result = + ((case #method requestMessage of + "initialize" => + mapResult + printInitializeResponse + ((#initialize handlers) + (parseInitializeParams (#params requestMessage))) + | "textDocument/hover" => + mapResult + printHoverResponse + ((#textDocument_hover handlers) + toclient + (parseHoverReq (#params requestMessage))) + | "textDocument/completion" => + mapResult + printCompletionResp + ((#textDocument_completion handlers) + (parseCompletionReq (#params requestMessage))) + | "shutdown" => + mapResult + (fn () => Json.Null) + ((#shutdown handlers) ()) + | "exit" => + OS.Process.exit OS.Process.success + | method => (debug ("Method not supported: " ^ method); + Error (~32601, "Method not supported: " ^ method))) + handle LspError (InternalError str) => Error (~32603, str) + | ex => Error (~32603, (General.exnMessage ex)) + ) + (* 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 => + 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) => + 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 + , textDocument_didOpen: toclient -> didOpenParams -> unit + , textDocument_didChange: toclient -> didChangeParams -> unit + , textDocument_didSave: toclient -> didSaveParams -> unit + , textDocument_didClose: toclient -> didCloseParams -> unit + } + fun handleNotification + (notification: {method: string, params: Json.json}) + (handlers: notificationHandlers) + = + (case #method notification of + "initialized" => (#initialized handlers) () + | "textDocument/didOpen" => (#textDocument_didOpen handlers) toclient (parseDidOpenParams (#params notification)) + | "textDocument/didChange" => (#textDocument_didChange handlers) toclient (parseDidChangeParams (#params notification)) + | "textDocument/didSave" => (#textDocument_didSave handlers) toclient (parseDidSaveParams (#params notification)) + | "textDocument/didClose" => (#textDocument_didClose handlers) toclient (parseDidCloseParams (#params notification)) + | m => debug ("Notification method not supported: " ^ m)) + handle LspError (InternalError str) => showMessage str 1 + | ex => showMessage (General.exnMessage ex) 1 + +end diff --git a/src/sources b/src/sources index c407ea2a..74171365 100644 --- a/src/sources +++ b/src/sources @@ -280,6 +280,11 @@ $(SRC)/getinfo.sml $(SRC)/json.sig $(SRC)/json.sml +$(SRC)/fromjson.sig +$(SRC)/fromjson.sml + +$(SRC)/lspspec.sml + $(SRC)/lsp.sig $(SRC)/lsp.sml -- cgit v1.2.3