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/lsp.sml | 537 ++---------------------------------------------------------- 1 file changed, 11 insertions(+), 526 deletions(-) (limited to 'src/lsp.sml') 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 -- cgit v1.2.3