From f5bfb7ab3a23485230a97b87ac5839eea8c79486 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Sun, 8 Dec 2019 20:50:40 +0100 Subject: Added initial version of lsp --- src/json.sml | 275 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 275 insertions(+) create mode 100644 src/json.sml (limited to 'src/json.sml') diff --git a/src/json.sml b/src/json.sml new file mode 100644 index 00000000..fab15a6c --- /dev/null +++ b/src/json.sml @@ -0,0 +1,275 @@ +(******************************************************************************* +* Standard ML JSON parser +* Copyright (C) 2010 Gian Perrone +* +* This program is free software: you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation, either version 3 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program. If not, see . +******************************************************************************) + +signature JSON_CALLBACKS = +sig + type json_data + + val json_object : json_data list -> json_data + val json_pair : string * json_data -> json_data + val json_array : json_data list -> json_data + val json_value : json_data -> json_data + val json_string : string -> json_data + val json_int : int -> json_data + val json_real : real -> json_data + val json_bool : bool -> json_data + val json_null : unit -> json_data + + val error_handle : string * int * string -> json_data +end + +functor JSONParser (Callbacks : JSON_CALLBACKS) = +struct + type json_data = Callbacks.json_data + + exception JSONParseError of string * int + + val inputData = ref "" + val inputPosition = ref 0 + + fun isDigit () = Char.isDigit (String.sub (!inputData,0)) + + fun ws () = while (String.isPrefix " " (!inputData) orelse + String.isPrefix "\n" (!inputData) orelse + String.isPrefix "\t" (!inputData) orelse + String.isPrefix "\r" (!inputData)) + do (inputData := String.extract (!inputData, 1, NONE)) + + fun peek () = String.sub (!inputData,0) + fun take () = + String.sub (!inputData,0) before + inputData := String.extract (!inputData, 1, NONE) + + fun matches s = (ws(); String.isPrefix s (!inputData)) + fun consume s = + if matches s then + (inputData := String.extract (!inputData, size s, NONE); + inputPosition := !inputPosition + size s) + else + raise JSONParseError ("Expected '"^s^"'", !inputPosition) + + fun parseObject () = + if not (matches "{") then + raise JSONParseError ("Expected '{'", !inputPosition) + else + (consume "{"; ws (); + if matches "}" then Callbacks.json_object [] before consume "}" + else + (Callbacks.json_object (parseMembers ()) + before (ws (); consume "}"))) + + and parseMembers () = + parsePair () :: + (if matches "," then (consume ","; parseMembers ()) else []) + + and parsePair () = + Callbacks.json_pair (parseString (), + (ws(); consume ":"; parseValue ())) + + and parseArray () = + if not (matches "[") then + raise JSONParseError ("Expected '['", !inputPosition) + else + (consume "["; + if matches "]" then + Callbacks.json_array [] before consume "]" + else + Callbacks.json_array (parseElements ()) before (ws (); consume "]")) + + and parseElements () = + parseValue () :: + (if matches "," then (consume ","; parseElements ()) else []) + + and parseValue () = + Callbacks.json_value ( + if matches "\"" then Callbacks.json_string (parseString ()) else + if matches "-" orelse isDigit () then parseNumber () else + if matches "true" then Callbacks.json_bool true before consume "true" else + if matches "false" then Callbacks.json_bool false before consume "false" else + if matches "null" then Callbacks.json_null () before consume "null" else + if matches "[" then parseArray () else + if matches "{" then parseObject () else + raise JSONParseError ("Expected value", !inputPosition)) + + and parseString () = + (ws () ; + consume ("\"") ; + parseChars () before consume "\"") + + and parseChars () = + let + fun pickChars s = + if peek () = #"\"" (* " *) then s else + pickChars (s ^ String.str (take ())) + in + pickChars "" + end + + and parseNumber () = + let + val i = parseInt () + in + if peek () = #"e" orelse peek () = #"E" then + Callbacks.json_int (valOf (Int.fromString (i^parseExp()))) + else if peek () = #"." then + let + val f = parseFrac() + + val f' = if peek() = #"e" orelse peek() = #"E" then + i ^ f ^ parseExp () + else i ^ f + in + Callbacks.json_real (valOf (Real.fromString f')) + end + else Callbacks.json_int (valOf (Int.fromString i)) + end + + and parseInt () = + let + val f = + if peek () = #"0" then + raise JSONParseError ("Invalid number", !inputPosition) + else if peek () = #"-" then (take (); "~") + else String.str (take ()) + in + f ^ parseDigits () + end + + and parseDigits () = + let + val r = ref "" + in + (while Char.isDigit (peek ()) do + r := !r ^ String.str (take ()); + !r) + end + + and parseFrac () = + (consume "." ; + "." ^ parseDigits ()) + + and parseExp () = + let + val _ = + if peek () = #"e" orelse + peek () = #"E" then take () + else + raise JSONParseError ("Invalid number", !inputPosition) + + val f = if peek () = #"-" then (take (); "~") + else if peek () = #"+" then (take (); "") + else "" + in + "e" ^ f ^ parseDigits () + end + + fun parse s = + (inputData := s ; + inputPosition := 0 ; + parseObject ()) handle JSONParseError (m,p) => + Callbacks.error_handle (m,p,!inputData) +end + +structure JsonIntermAst = +struct +datatype ast = + Array of ast list + | Null + | Float of real + | String of string + | Bool of bool + | Int of int + | Pair of (string * ast) + | Obj of ast list +end + +structure Json :> JSON = struct +datatype json = + Array of json list + | Null + | Float of real + | String of string + | Bool of bool + | Int of int + | Obj of (string * json) list + +fun fromInterm (interm: JsonIntermAst.ast): json = + case interm of + JsonIntermAst.Array l => Array (List.map fromInterm l) + | JsonIntermAst.Null => Null + | JsonIntermAst.Float r => Float r + | JsonIntermAst.String s => String s + | JsonIntermAst.Bool b => Bool b + | JsonIntermAst.Int i => Int i + | JsonIntermAst.Pair (k,v) => + raise Fail ("JSON Parsing error. Pair of JSON found where it shouldn't. Key = " ^ k) + | JsonIntermAst.Obj l => + Obj + (List.foldl + (fn (a, acc) => + case a of + JsonIntermAst.Pair (k, v) => (k, fromInterm v) :: acc + | JsonIntermAst.Array _ => raise Fail ("JSON Parsing error. Found Array in object instead of key-value pair") + | JsonIntermAst.Null => raise Fail ("JSON Parsing error. Found Null in object instead of key-value pair") + | JsonIntermAst.Float _ => raise Fail ("JSON Parsing error. Found Float in object instead of key-value pair") + | JsonIntermAst.String _ => raise Fail ("JSON Parsing error. Found String in object instead of key-value pair") + | JsonIntermAst.Bool _ => raise Fail ("JSON Parsing error. Found Bool in object instead of key-value pair") + | JsonIntermAst.Int _ => raise Fail ("JSON Parsing error. Found Int in object instead of key-value pair") + | JsonIntermAst.Obj _ => raise Fail ("JSON Parsing error. Found Obj in object instead of key-value pair") + ) [] l) + +structure StandardJsonParserCallbacks = +struct + type json_data = JsonIntermAst.ast + fun json_object l = JsonIntermAst.Obj l + fun json_pair (k,v) = JsonIntermAst.Pair (k,v) + fun json_array l = JsonIntermAst.Array l + fun json_value x = x + fun json_string s = JsonIntermAst.String s + fun json_int i = JsonIntermAst.Int i + fun json_real r = JsonIntermAst.Float r + fun json_bool b = JsonIntermAst.Bool b + fun json_null () = JsonIntermAst.Null + fun error_handle (msg,pos,data) = + raise Fail ("Error: " ^ msg ^ " near " ^ Int.toString pos ^ " data: " ^ + data) +end + +structure MyJsonParser = JSONParser (StandardJsonParserCallbacks) + +fun parse (str: string): json = + fromInterm (MyJsonParser.parse str) +fun print (ast: json): string = + case ast of + Array l => "[" + ^ List.foldl (fn (a, acc) => acc ^ "," ^ print a) "" l + ^ "]" + | Null => "null" + | Float r => Real.toString r + | String s => + "\"" ^ + String.translate + (fn c => if c = #"\"" then "\\\"" else Char.toString c) + s ^ + "\"" + | 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 + ^ "}" +end -- cgit v1.2.3 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(-) (limited to 'src/json.sml') 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 From e4f98c318fcadff9247c83d1659a39b15e8c9d58 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Tue, 10 Dec 2019 22:44:51 +0100 Subject: First working version of publishDiagnostics --- src/json.sml | 12 ++++-- src/lsp.sml | 120 +++++++++++++++++++++++++++++++++-------------------------- 2 files changed, 76 insertions(+), 56 deletions(-) (limited to 'src/json.sml') diff --git a/src/json.sml b/src/json.sml index f189cc4d..cc9ea6ae 100644 --- a/src/json.sml +++ b/src/json.sml @@ -114,8 +114,12 @@ struct and parseChars () = let fun pickChars s = - if peek () = #"\"" (* " *) then s else - pickChars (s ^ String.str (take ())) + if peek () = #"\"" (* " *) + then s + else + if peek () = #"\\" andalso (String.sub (!inputData, 1)) = #"\"" + then (consume "\\\""; pickChars (s ^ "\"")) + else pickChars (s ^ String.str (take ())) in pickChars "" end @@ -256,8 +260,8 @@ fun parse (str: string): json = fun print (ast: json): string = case ast of Array l => "[" - ^ List.foldl (fn (a, acc) => acc ^ "," ^ print a) "" l - ^ "]" + ^ List.foldl (fn (a, acc) => acc ^ (if acc = "" then "" else ", ") ^ print a) "" l + ^ "]" | Null => "null" | Float r => Real.toString r | String s => diff --git a/src/lsp.sml b/src/lsp.sml index 976faa25..175a71ee 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -1,4 +1,6 @@ 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 @@ -98,7 +100,7 @@ structure LspSpec (* :> LSPSPEC *) = struct 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 <> #"#") (Substring.triml 1 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) @@ -116,7 +118,7 @@ structure LspSpec (* :> LSPSPEC *) = struct end fun printDocumentUri (d: documentUri) = (#scheme d) ^ "://" ^ - (#authority d) ^ "/" ^ + (#authority d) ^ (#path d) ^ (if #query d <> "" then "?" ^ #query d else "") ^ (if #fragment d <> "" then "#" ^ #fragment d else "") @@ -274,11 +276,27 @@ structure LspSpec (* :> LSPSPEC *) = struct } 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)]) - ])); - fun publishDiagnostics diags = TextIO.print (Json.print (printPublishDiagnosticsParams diags)) + 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 + (debug ("Sending diagnostics: " ^ toPrint); + TextIO.print toPrint) + end val toclient: toclient = {showMessage = showMessage, publishDiagnostics = publishDiagnostics} fun handleMessage @@ -351,8 +369,7 @@ structure LspSpec (* :> LSPSPEC *) = struct | "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)) - | m => (TextIO.output ( TextIO.stdErr, "Notification method not supported: " ^ m); - TextIO.flushOut TextIO.stdErr) + | m => debug ("Notification method not supported: " ^ m) end @@ -394,11 +411,12 @@ fun initState (initParams: LspSpec.initializeParams): state = val rootPath = case #rootUri initParams of NONE => raise Fail "No rootdir found" | SOME a => #path a + (* val () = debug ("Scanning dir: " ^ rootPath) *) val foundUrps = scanDir (fn fname => OS.Path.ext fname = SOME "urp") rootPath in { urpPath = case foundUrps of [] => raise Fail ("No .urp files found in path " ^ rootPath) - | one :: [] => one + | one :: [] => OS.Path.base (OS.Path.file one) | many => raise Fail ("Found multiple .urp files in path " ^ rootPath) , fileStates = SM.empty } @@ -425,7 +443,6 @@ fun addSgnToEnv (env: ElabEnv.env) (sgn: Source.sgn_item list) (fileName: string env' end -(* TODO: get errors from elaboration and subsgn and make Diagnostics from these *) fun calculateFileState (state: state) (fileName: string): (fileState * LspSpec.diagnostic list) = let (* TODO Optim: cache parsed urp file? *) @@ -474,27 +491,26 @@ fun calculateFileState (state: state) (fileName: string): (fileState * LspSpec.d (Source.StrConst parsedUr, {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}) (* TODO definitely not sure about this one, just copied from "top" processing *) - val () = case gs of - [] => () - | _ => app (fn Elaborate.Disjoint (loc, env, denv, c1, c2) => - (case Disjoint.prove env denv (c1, c2, loc) of - [] => () - | _ => - (Print.prefaces "Unresolved constraint in top.ur" - [("loc", Print.PD.string (ErrorMsg.spanToString loc)), - ("c1", ElabPrint.p_con env c1), - ("c2", ElabPrint.p_con env c2)]; - raise Fail "Unresolved constraint in top.ur")) - | Elaborate.TypeClass (env, c, r, loc) => - () - (* let *) - (* val c = normClassKey env c *) - (* in *) - (* case resolveClass env c of *) - (* SOME e => r := SOME e *) - (* | NONE => expError env (Unresolvable (loc, c)) *) - (* end *) - ) gs + (* val () = case gs of *) + (* [] => () *) + (* | _ => app (fn Elaborate.Disjoint (loc, env, denv, c1, c2) => *) + (* (case Disjoint.prove env denv (c1, c2, loc) of *) + (* [] => () *) + (* | _ => *) + (* (Print.prefaces "Unresolved constraint in top.ur" *) + (* [("loc", Print.PD.string (ErrorMsg.spanToString loc)), *) + (* ("c1", ElabPrint.p_con env c1), *) + (* ("c2", ElabPrint.p_con env c2)]; *) + (* raise Fail "Unresolved constraint in top.ur")) *) + (* | Elaborate.TypeClass (env, c, r, loc) => *) + (* let *) + (* val c = normClassKey env c *) + (* in *) + (* case resolveClass env c of *) + (* SOME e => r := SOME e *) + (* | NONE => expError env (Unresolvable (loc, c)) *) + (* end *) + (* ) gs *) val (sgn, gs) = Elaborate.elabSgn (envBeforeThisFile, Disjoint.empty) ( Source.SgnConst (case parsedUrs of NONE => [] | SOME a => a) @@ -502,17 +518,19 @@ fun calculateFileState (state: state) (fileName: string): (fileState * LspSpec.d val () = case gs of [] => () | _ => raise Fail ("Unresolved disjointness constraints in " ^ fileName) (* TODO not sure? *) val () = Elaborate.subSgn envBeforeThisFile ErrorMsg.dummySpan sgn' sgn val errors = ErrorMsg.readErrorLog () + val decls = case str of + (Elab.StrConst decls, _) => decls + | _ => raise Fail ("Impossible: Source.StrConst did not become Elab.StrConst after elaboration") + val () = debug ("Finished calculateFileState for " ^ fileName ^ " with " ^ Int.toString (List.length errors) ^ " errors. " ^ Int.toString (List.length decls) ^ " decls found") in ({ envOfPreviousModules = envBeforeThisFile - , decls = case str of - (Elab.StrConst decls, _) => decls - | _ => raise Fail ("Impossible: Source.StrConst did not become Elab.StrConst after elaboration") + , decls = decls }, List.map - (fn err => { range = { start = { line = #line (#first (#span err)) + (fn err => { range = { start = { line = #line (#first (#span err)) - 1 , character = #char (#first (#span err)) } - , end_ = { line = #line (#last (#span err)) + , end_ = { line = #line (#last (#span err)) - 1 , character = #char (#last (#span err)) } } @@ -535,16 +553,14 @@ fun handleFullDocument (state: state) (toclient: LspSpec.toclient) (documentUri: , path , #1 res) }; - case #2 res of - [] => () - | diags => #publishDiagnostics toclient { uri = documentUri , diagnostics = diags} + #publishDiagnostics toclient { uri = documentUri , diagnostics = #2 res} end fun serverLoop () = let val requestMessage = LspSpec.readRequestFromStdIO () - handle ex => (TextIO.output (TextIO.stdErr, General.exnMessage ex ^ "\n"); TextIO.flushOut TextIO.stdErr ; raise ex) + handle ex => (debug (General.exnMessage ex) ; raise ex) val state = !stateRef in case state of @@ -554,17 +570,17 @@ fun serverLoop () = LspSpec.handleMessage m { initialize = fn _ => - let val st = initState (LspSpec.parseInitializeParams (#params m)) - in - stateRef := SOME st; - LspSpec.Success - { capabilities = - { hoverProvider = true - , textDocumentSync = { openClose = true + (let val st = initState (LspSpec.parseInitializeParams (#params m)) + in + stateRef := SOME st; + LspSpec.Success + { capabilities = + { hoverProvider = true + , textDocumentSync = { openClose = true , save = SOME { includeText = false } - }} - } - end + }} + } + end) handle (Fail str) => LspSpec.Error (~32602, str) , shutdown = fn () => LspSpec.Error (~32002, "Server not initialized") , textDocument_hover = fn ctx => fn _ => LspSpec.Error (~32002, "Server not initialized") @@ -587,7 +603,7 @@ fun serverLoop () = , 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) + ) handle ex => (debug (General.exnMessage ex); raise ex) end fun startServer () = while true do serverLoop () -- cgit v1.2.3 From a0efdaf11337df1fb1a5478f9a193a2737b2665b Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Wed, 11 Dec 2019 12:31:50 +0100 Subject: Fixed parsing errors and loading of interfaces --- src/json.sml | 4 +- src/lsp.sml | 262 ++++++++++++++++++++++++++++++++++++----------------------- 2 files changed, 163 insertions(+), 103 deletions(-) (limited to 'src/json.sml') diff --git a/src/json.sml b/src/json.sml index cc9ea6ae..656d28ff 100644 --- a/src/json.sml +++ b/src/json.sml @@ -271,7 +271,9 @@ fun print (ast: json): string = s ^ "\"" | Bool b => if b then "true" else "false" - | Int i => Int.toString i + | Int i => if i >= 0 + then (Int.toString i) + else "-" ^ (Int.toString (Int.abs i)) (* default printing uses ~ instead of - *) | Obj l => "{" ^ List.foldl (fn ((k, v), acc) => acc ^ (if acc = "" then "" else ", ") ^ "\"" ^ k ^ "\": " ^ print v ) "" l ^ "}" diff --git a/src/lsp.sml b/src/lsp.sml index 658ca7a6..34209231 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -294,8 +294,7 @@ structure LspSpec (* :> LSPSPEC *) = struct ])) val toPrint = "Content-Length:" ^ Int.toString (String.size jsonToPrint) ^ "\r\n\r\n" ^ jsonToPrint in - (debug ("Sending diagnostics: " ^ toPrint); - TextIO.print toPrint) + TextIO.print toPrint end val toclient: toclient = {showMessage = showMessage, publishDiagnostics = publishDiagnostics} @@ -375,6 +374,42 @@ 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 + structure SK = struct type ord_key = string val compare = String.compare @@ -411,7 +446,6 @@ fun initState (initParams: LspSpec.initializeParams): state = val rootPath = case #rootUri initParams of NONE => raise Fail "No rootdir found" | SOME a => #path a - (* val () = debug ("Scanning dir: " ^ rootPath) *) val foundUrps = scanDir (fn fname => OS.Path.ext fname = SOME "urp") rootPath in { urpPath = case foundUrps of @@ -438,110 +472,126 @@ fun addSgnToEnv (env: ElabEnv.env) (sgn: Source.sgn_item list) (fileName: string val (env', n) = ElabEnv.pushStrNamed env moduleName sgn val (_, env') = if addUnprefixed then Elaborate.dopen env' {str = n, strs = [], sgn = sgn} - else ([], env) + else ([], env') in env' end -(* TODO: Any parse error -> valOf fails, throws and server crashes *) -fun calculateFileState (state: state) (fileName: string): (fileState * LspSpec.diagnostic list) = +fun errorToDiagnostic (err: { span: ErrorMsg.span , message: string }): LspSpec.diagnostic = + { range = { start = { line = #line (#first (#span err)) - 1 + , character = #char (#first (#span err)) + } + , end_ = { line = #line (#last (#span err)) - 1 + , character = #char (#last (#span err)) + } + } + , severity = 1 + , source = "UrWeb" + , message = #message err + } + +(* TODO FFI modules ? Check compiler.sml -> parse -> parseFfi *) +(* TODO Optim: cache parsed urp file? *) +fun calculateFileState (state: state) (fileName: string): (fileState option * LspSpec.diagnostic list) = let - (* TODO Optim: cache parsed urp file? *) val () = if (OS.Path.ext fileName = SOME "ur") then () else raise Fail ("Can only handle .ur files for now") val () = Elaborate.unifyMore := true - val job = valOf (C.run (C.transform C.parseUrp "parseUrp") (#urpPath state)) - fun entryInUrpToFileName (entry: string) (ext: string) = (#urpPath state) ^ "/" ^ entry ^ ext - val modulesBeforeAndAfterThisFile = - List.partition (fn entry => entryInUrpToFileName entry ".ur" = fileName) (#sources job) - val () = case #2 modulesBeforeAndAfterThisFile of - [] => - (* Module we're handling should always be in here *) - raise Fail ("Couldn't find file " ^ fileName ^ " referenced in .urp file at " ^ (#urpPath state)) - | _ => () + (* 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))) + | SOME a => a + val moduleSearchRes = + List.foldl + (fn (entry, acc) => if #2 acc + then acc + else + if entry ^ ".ur" = fileName + then (List.rev (#1 acc), true) + else (entry :: #1 acc, false)) + ([] (* modules before *), false (* module found *)) + (#sources job) + 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))) + (* Parsing .urs files of previous modules *) val parsedUrss = List.map (fn entry => let - val fileName = entryInUrpToFileName entry ".urs" + val fileName = entry ^ ".urs" in { fileName = fileName , parsed = if OS.FileSys.access (fileName, []) - then raise (Fail ("Couldn't find an .urs file for " ^ fileName)) - else valOf (C.run (C.transform C.parseUrs "parseUrs") fileName)} + then case C.run (C.transform C.parseUrs "parseUrs") fileName of + NONE => raise LspError (InternalError ("Failed to parse .urs file at " ^ fileName)) + | SOME a => a + else raise LspError (InternalError ("Couldn't find an .urs file for " ^ fileName)) + } end) - (#1 modulesBeforeAndAfterThisFile) - val parsedBasisUrs = valOf (C.run (C.transform C.parseUrs "parseUrs") (Settings.libFile "basis.urs")) - val parsedTopUrs = valOf (C.run (C.transform C.parseUrs "parseUrs") (Settings.libFile "top.urs")) + modulesBeforeThisFile + (* Parsing Basis and Top .urs *) + val parsedBasisUrs = + case C.run (C.transform C.parseUrs "parseUrs") (Settings.libFile "basis.urs") of + NONE => raise LspError (InternalError ("Failed to parse basis.urs file at " ^ (Settings.libFile "basis.urs"))) + | SOME a => a + val parsedTopUrs = + case C.run (C.transform C.parseUrs "parseUrs") (Settings.libFile "top.urs") of + NONE => raise LspError (InternalError ("Failed to parse top.urs file at " ^ (Settings.libFile "top.urs"))) + | SOME a => a + (* Building env with previous .urs files *) val envWithStdLib = addSgnToEnv (addSgnToEnv ElabEnv.empty parsedBasisUrs (Settings.libFile "basis.urs") true) parsedTopUrs (Settings.libFile "top.urs") true val envBeforeThisFile = List.foldl (fn (sgn, env) => addSgnToEnv env (#parsed sgn) (#fileName sgn) false) envWithStdLib parsedUrss - val (parsedUr: Source.decl list) = - valOf (C.run (C.transform C.parseUr "parseUr") fileName) + (* Parsing .ur and .urs of current file *) val (parsedUrs: (Source.sgn_item list) option) = - if OS.FileSys.access (fileName ^ "s", []) then - SOME (valOf (C.run (C.transform C.parseUrs "parseUrs") (fileName ^ "s"))) - else - NONE + (if OS.FileSys.access (fileName ^ "s", []) + then + case C.run (C.transform C.parseUrs "parseUrs") (fileName ^ "s") of + NONE => NONE + | SOME a => SOME a + else + NONE) handle ex => NONE val () = ErrorMsg.resetErrors () - val (str, sgn', gs) = - Elaborate.elabStr - (envBeforeThisFile, Disjoint.empty) - (Source.StrConst parsedUr, {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}) - - (* TODO definitely not sure about this one, just copied from "top" processing *) - (* val () = case gs of *) - (* [] => () *) - (* | _ => app (fn Elaborate.Disjoint (loc, env, denv, c1, c2) => *) - (* (case Disjoint.prove env denv (c1, c2, loc) of *) - (* [] => () *) - (* | _ => *) - (* (Print.prefaces "Unresolved constraint in top.ur" *) - (* [("loc", Print.PD.string (ErrorMsg.spanToString loc)), *) - (* ("c1", ElabPrint.p_con env c1), *) - (* ("c2", ElabPrint.p_con env c2)]; *) - (* raise Fail "Unresolved constraint in top.ur")) *) - (* | Elaborate.TypeClass (env, c, r, loc) => *) - (* let *) - (* val c = normClassKey env c *) - (* in *) - (* case resolveClass env c of *) - (* SOME e => r := SOME e *) - (* | NONE => expError env (Unresolvable (loc, c)) *) - (* end *) - (* ) gs *) - val (sgn, gs) = Elaborate.elabSgn - (envBeforeThisFile, Disjoint.empty) - ( Source.SgnConst (case parsedUrs of NONE => [] | SOME a => a) - , {file = fileName ^ "s", first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}) - val () = case gs of [] => () | _ => raise Fail ("Unresolved disjointness constraints in " ^ fileName) (* TODO not sure? *) - val () = Elaborate.subSgn envBeforeThisFile ErrorMsg.dummySpan sgn' sgn - val errors = ErrorMsg.readErrorLog () - val decls = case str of - (Elab.StrConst decls, _) => decls - | _ => raise Fail ("Impossible: Source.StrConst did not become Elab.StrConst after elaboration") - val () = debug ("Finished calculateFileState for " ^ fileName ^ " with " ^ Int.toString (List.length errors) ^ " errors. " ^ Int.toString (List.length decls) ^ " decls found") + val (parsedUrO: (Source.decl list) option) = + C.run (C.transform C.parseUr "parseUr") fileName in - ({ envOfPreviousModules = envBeforeThisFile - , decls = decls - }, - List.map - (fn err => { range = { start = { line = #line (#first (#span err)) - 1 - , character = #char (#first (#span err)) - } - , end_ = { line = #line (#last (#span err)) - 1 - , character = #char (#last (#span err)) - } - } - , severity = 1 - , source = "UrWeb" - , message = #message err - } - ) - errors - ) + case parsedUrO of + NONE => (* Parse error *) (NONE, List.map errorToDiagnostic (ErrorMsg.readErrorLog ())) + | SOME parsedUr => + (* .ur file found -> typecheck *) + let + val (str, sgn', gs) = + Elaborate.elabStr + (envBeforeThisFile, Disjoint.empty) + (Source.StrConst parsedUr, {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}) + val () = + (* .urs file found -> check and compare with .ur file *) + (case parsedUrs of + NONE => () + | SOME parsedUrs => + let + val (sgn, gs) = Elaborate.elabSgn + (envBeforeThisFile, Disjoint.empty) + ( Source.SgnConst parsedUrs + , {file = fileName ^ "s", first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}); + in + Elaborate.subSgn envBeforeThisFile ErrorMsg.dummySpan sgn' sgn + end) + (* report back errors (as Diagnostics) *) + val errors = ErrorMsg.readErrorLog () + val decls = case str of + (Elab.StrConst decls, _) => decls + | _ => raise Fail ("Impossible: Source.StrConst did not become Elab.StrConst after elaboration") + in + (SOME { envOfPreviousModules = envBeforeThisFile + , decls = decls + }, + List.map errorToDiagnostic errors) + end end fun handleFullDocument (state: state) (toclient: LspSpec.toclient) (documentUri: LspSpec.documentUri) = @@ -549,11 +599,14 @@ fun handleFullDocument (state: state) (toclient: LspSpec.toclient) (documentUri: val path = #path documentUri val res = calculateFileState state path in - stateRef := SOME { urpPath = #urpPath state - , fileStates = SM.insert ( #fileStates state - , path - , #1 res) - }; + (case #1 res of + NONE => () + | SOME fs => + stateRef := SOME { urpPath = #urpPath state + , fileStates = SM.insert ( #fileStates state + , path + , fs) + }) ; #publishDiagnostics toclient { uri = documentUri , diagnostics = #2 res} end @@ -590,21 +643,26 @@ fun serverLoop () = | SOME state => (case requestMessage of LspSpec.Notification n => - LspSpec.handleNotification - n - { initialized = fn () => () - , textDocument_didOpen = fn ctx => fn p => handleFullDocument state ctx (#uri (#textDocument p)) - , textDocument_didChange = fn ctx => fn didChangeParams => () - , textDocument_didSave = fn ctx => fn p => handleFullDocument state ctx (#uri (#textDocument p)) - } + ((LspSpec.handleNotification + n + { initialized = fn () => () + , textDocument_didOpen = fn ctx => fn p => handleFullDocument state ctx (#uri (#textDocument p)) + , textDocument_didChange = fn ctx => fn didChangeParams => () + , textDocument_didSave = fn ctx => fn p => handleFullDocument state ctx (#uri (#textDocument p)) + }) + handle LspError e => handleLspErrorInNotification e + | ex => handleLspErrorInNotification (InternalError (General.exnMessage ex))) | LspSpec.RequestMessage m => - LspSpec.handleMessage - m - { initialize = fn _ => LspSpec.Error (~32600, "Server already initialized") - , shutdown = fn () => LspSpec.Success () - , textDocument_hover = fn ctx => fn _ => LspSpec.Success NONE - } - ) handle ex => (debug (General.exnMessage ex); raise ex) + (* TODO should error handling here be inside handleMessage? *) + ((LspSpec.handleMessage + m + { initialize = fn _ => LspSpec.Error (~32600, "Server already initialized") + , shutdown = fn () => LspSpec.Success () + , textDocument_hover = fn ctx => fn _ => LspSpec.Success NONE + }) + handle LspError e => handleLspErrorInRequest (#id m) e + | ex => handleLspErrorInRequest (#id m) (InternalError (General.exnMessage ex))) + ) end fun startServer () = while true do serverLoop () -- cgit v1.2.3 From faff2d8ac927fd49f13fbaf9b84ffc99bbb6f9b8 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Thu, 12 Dec 2019 22:44:50 +0100 Subject: Added tracking of text of source files and autocomplete --- derivation.nix | 4 +- shell.nix | 8 +- src/elab_env.sig | 4 + src/elab_env.sml | 9 +- src/elab_print.sig | 1 + src/getinfo.sig | 20 ++- src/getinfo.sml | 51 ++++--- src/json.sml | 11 +- src/lsp.sml | 399 +++++++++++++++++++++++++++++++++++++++++++++++------ 9 files changed, 438 insertions(+), 69 deletions(-) (limited to 'src/json.sml') diff --git a/derivation.nix b/derivation.nix index f956a619..19582948 100644 --- a/derivation.nix +++ b/derivation.nix @@ -1,6 +1,6 @@ { stdenv, lib, fetchFromGitHub, file, openssl, mlton , mysql, postgresql, sqlite, gcc -, automake, autoconf, libtool, icu +, automake, autoconf, libtool, icu, nix-gitignore }: stdenv.mkDerivation rec { @@ -18,7 +18,7 @@ stdenv.mkDerivation rec { # rev = "e52ce9f542f64750941cfd84efdb6d993ee20ff0"; # sha256 = "19ba5n7g1dxy7q9949aakqplchsyzwrrnxv8v604vx5sg7fdfn3b"; # }; - src = ./.; + src = nix-gitignore.gitignoreSource [] ./.; buildInputs = [ openssl mlton mysql.connector-c postgresql sqlite automake autoconf libtool icu.dev openssl.dev]; diff --git a/shell.nix b/shell.nix index 95da550b..e9b047ee 100644 --- a/shell.nix +++ b/shell.nix @@ -1 +1,7 @@ -import ./default.nix +let + pkgs = import {}; + def = import ./default.nix; +in +pkgs.mkShell { + buildInputs = def.buildInputs; +} diff --git a/src/elab_env.sig b/src/elab_env.sig index 47b31c08..55909b53 100644 --- a/src/elab_env.sig +++ b/src/elab_env.sig @@ -85,6 +85,8 @@ signature ELAB_ENV = sig val pushENamedAs : env -> string -> int -> Elab.con -> env val lookupENamed : env -> int -> string * Elab.con val checkENamed : env -> int -> bool + val matchNamedEByPrefix: env -> string -> (string * Elab.con) list + val matchRelEByPrefix: env -> string -> (string * Elab.con) list val lookupE : env -> string -> Elab.con var @@ -100,6 +102,8 @@ signature ELAB_ENV = sig val lookupStrNamed : env -> int -> string * Elab.sgn val lookupStr : env -> string -> (int * Elab.sgn) option + val matchStrByPrefix: env -> string -> (string * (int * Elab.sgn)) list + val edeclBinds : env -> Elab.edecl -> env val declBinds : env -> Elab.decl -> env diff --git a/src/elab_env.sml b/src/elab_env.sml index a2097aa9..e79b665d 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -932,6 +932,12 @@ fun lookupENamed (env : env) n = NONE => raise UnboundNamed n | SOME x => x +fun matchNamedEByPrefix (env: env) (str: string) = + List.filter (fn (name,con) => String.isPrefix str name) (IM.listItems (#namedE env)) + +fun matchRelEByPrefix (env: env) (str: string) = + List.filter (fn (name,con) => String.isPrefix str name) (#relE env) + fun checkENamed (env : env) n = Option.isSome (IM.find (#namedE env, n)) @@ -985,7 +991,8 @@ fun lookupStrNamed (env : env) n = | SOME x => x fun lookupStr (env : env) x = SM.find (#renameStr env, x) - +fun matchStrByPrefix (env: env) prefix = + List.filter (fn (name,_) => String.isPrefix prefix name) (SM.listItemsi (#renameStr env)) fun sgiSeek (sgi, (sgns, strs, cons)) = case sgi of diff --git a/src/elab_print.sig b/src/elab_print.sig index 1eb832b3..84715b9d 100644 --- a/src/elab_print.sig +++ b/src/elab_print.sig @@ -38,6 +38,7 @@ signature ELAB_PRINT = sig val p_sgn : ElabEnv.env -> Elab.sgn Print.printer val p_str : ElabEnv.env -> Elab.str Print.printer val p_file : ElabEnv.env -> Elab.file Print.printer + val debug : bool ref end diff --git a/src/getinfo.sig b/src/getinfo.sig index 334e19f1..50eee70a 100644 --- a/src/getinfo.sig +++ b/src/getinfo.sig @@ -26,11 +26,29 @@ *) signature GET_INFO = sig + + datatype item = + Kind of Elab.kind + | Con of Elab.con + | Exp of Elab.exp + | Sgn_item of Elab.sgn_item + | Sgn of Elab.sgn + | Str of Elab.str + | Decl of Elab.decl + val getInfo: ElabEnv.env -> Elab.str' -> string (* fileName *) -> { line: int , character: int} -> - Print.PD.pp_desc + { smallest : { span : ErrorMsg.span + , item : item + , env : ElabEnv.env } + , smallestgoodpart : { span : ErrorMsg.span + , desc : Print.PD.pp_desc + , env : ElabEnv.env + , item : item + } option +} end diff --git a/src/getinfo.sml b/src/getinfo.sml index 7925aba3..1d657637 100644 --- a/src/getinfo.sml +++ b/src/getinfo.sml @@ -73,6 +73,19 @@ fun getSpan (f: item * E.env) = | Str s => #2 s | Decl d => #2 d +(* Just use ElabPrint functions. *) +(* These are better for compiler error messages, but it's better than nothing *) +fun printLiterally {span = span, item = item, env = env} = + P.box [ case item of + Kind k => P.box [P.PD.string "KIND: ", ElabPrint.p_kind env k] + | Con c => P.box [P.PD.string "CON: ", ElabPrint.p_con env c] + | Exp e => P.box [P.PD.string "EXP: ", ElabPrint.p_exp env e] + | Sgn_item si => P.box [P.PD.string "SGN_ITEM: ", ElabPrint.p_sgn_item env si] + | Sgn s => P.box [P.PD.string "SGN: ", ElabPrint.p_sgn env s] + | Str s => P.box [P.PD.string "STR: ", ElabPrint.p_str env s] + | Decl d => P.box [P.PD.string "DECL: ", ElabPrint.p_decl env d] + ] + fun getInfo env str fileName {line = row, character = col} = let val () = U.mliftConInCon := E.mliftConInCon @@ -89,19 +102,6 @@ fun getInfo env str fileName {line = row, character = col} = else env) env decls | _ => env) - (* Just use ElabPrint functions. *) - (* These are better for compiler error messages, but it's better than nothing *) - fun printLiterally {span = span, item = item, env = env} = - P.box [ case item of - Kind k => P.box [P.PD.string "KIND: ", ElabPrint.p_kind env k] - | Con c => P.box [P.PD.string "CON: ", ElabPrint.p_con env c] - | Exp e => P.box [P.PD.string "EXP: ", ElabPrint.p_exp env e] - | Sgn_item si => P.box [P.PD.string "SGN_ITEM: ", ElabPrint.p_sgn_item env si] - | Sgn s => P.box [P.PD.string "SGN: ", ElabPrint.p_sgn env s] - | Str s => P.box [P.PD.string "STR: ", ElabPrint.p_str env s] - | Decl d => P.box [P.PD.string "DECL: ", ElabPrint.p_decl env d] - ] - (* TODO We lose some really useful information, like eg. inferred parameters, *) (* which we do have in the actual items (L.Decl, L.Exp, etc) *) (* but not when we do a lookup into the Env *) @@ -161,7 +161,16 @@ fun getInfo env str fileName {line = row, character = col} = | Str s => NONE | Decl d => NONE) - fun add env item span acc = + fun add (env: ElabEnv.env) (item: item) (span: ErrorMsg.span) (acc: { smallest : { span : ErrorMsg.span + , item : item + , env : ElabEnv.env } + , smallestgoodpart : { span : ErrorMsg.span + , desc : P.PD.pp_desc + , env : ElabEnv.env + , item : item + } option + } + ) = if not (isPosIn fileName row col span) then acc @@ -176,14 +185,14 @@ fun getInfo env str fileName {line = row, character = col} = NONE => (case printGoodPart env item span of NONE => NONE - | SOME desc => SOME (desc, span)) - | SOME (desc', span') => + | SOME desc => SOME {desc = desc, span = span, env = env, item = item}) + | SOME (prev as {desc = desc', span = span', env = env', item = item'}) => if isSmallerThan span span' then (case printGoodPart env item span of - NONE => SOME (desc', span') - | SOME desc => SOME (desc, span)) - else SOME (desc', span') + NONE => SOME prev + | SOME desc => SOME {desc = desc, span = span, env = env, item = item}) + else SOME prev in {smallest = smallest, smallestgoodpart = smallestgoodpart} end @@ -228,8 +237,6 @@ fun getInfo env str fileName {line = row, character = col} = ( L.DStr (Compiler.moduleOf "fileName", 0, (L.SgnError, ErrorMsg.dummySpan), (str, {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos})) , {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}) in - case #smallestgoodpart result of - NONE => printLiterally (#smallest result) - | SOME (desc, span) => desc + result end end diff --git a/src/json.sml b/src/json.sml index 656d28ff..4f604cc4 100644 --- a/src/json.sml +++ b/src/json.sml @@ -113,13 +113,20 @@ struct and parseChars () = let + val escapedchars = ["n", "r", "b", "f", "t"] fun pickChars s = - if peek () = #"\"" (* " *) + if peek () = #"\"" (* " = end of string *) then s else if peek () = #"\\" andalso (String.sub (!inputData, 1)) = #"\"" then (consume "\\\""; pickChars (s ^ "\"")) - else pickChars (s ^ String.str (take ())) + else + if peek () = #"\\" andalso (String.sub (!inputData, 1)) = #"n" + then (consume "\\n"; pickChars (s ^ "\n")) + else + if peek () = #"\\" andalso (String.sub (!inputData, 1)) = #"r" + then (consume "\\r"; pickChars (s ^ "\r")) + else pickChars (s ^ String.str (take ())) in pickChars "" end diff --git a/src/lsp.sml b/src/lsp.sml index cfdec863..aaef422c 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -11,13 +11,17 @@ 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 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) + (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 @@ -161,6 +165,10 @@ structure LspSpec (* :> LSPSPEC *) = struct 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))] @@ -194,10 +202,23 @@ structure LspSpec (* :> LSPSPEC *) = struct fun parseDidOpenParams (params: Json.json): didOpenParams = { textDocument = parseTextDocumentItem (FromJson.get "textDocument" params) } - type didChangeParams = { textDocument: versionedTextDocumentIdentifier } + 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 = ... *) + , 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 } @@ -232,11 +253,77 @@ structure LspSpec (* :> LSPSPEC *) = struct 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 } }} @@ -246,11 +333,16 @@ structure LspSpec (* :> LSPSPEC *) = struct 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) )])] @@ -273,6 +365,7 @@ structure LspSpec (* :> LSPSPEC *) = struct { initialize: initializeParams -> initializeResponse result , shutdown: unit -> unit result , textDocument_hover: toclient -> hoverReq -> hoverResp result + , textDocument_completion: completionReq -> completionResp result } fun showMessage str typ = @@ -316,13 +409,19 @@ structure LspSpec (* :> LSPSPEC *) = struct ((#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 => Error (~32601, "Method not supported: " ^ method) + | 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 @@ -418,13 +517,21 @@ structure SM = BinaryMapFn(SK) type fileState = { envBeforeThisModule: ElabEnv.env - , decls : Elab.decl list } + , decls: Elab.decl list + , text: string} type state = { urpPath : string , fileStates : fileState SM.map } val stateRef = ref (NONE: state option) +fun insertFileState (state: state) (fileName: string) (fs: fileState) = + stateRef := SOME { urpPath = #urpPath state + , fileStates = SM.insert ( #fileStates state + , fileName + , fs) + } + fun scanDir (f: string -> bool) (path: string) = let val dir = OS.FileSys.openDir path @@ -491,12 +598,12 @@ fun errorToDiagnostic (err: { span: ErrorMsg.span , message: string }): LspSpec. (* TODO FFI modules ? Check compiler.sml -> parse -> parseFfi *) (* TODO Optim: cache parsed urp file? *) -fun calculateFileState (state: state) (fileName: string): (fileState option * LspSpec.diagnostic list) = +fun elabFile (state: state) (fileName: string): ({ decls: Elab.decl list, envBeforeThisModule: ElabEnv.env} option * LspSpec.diagnostic list) = let val () = if (OS.Path.ext fileName = SOME "ur") then () else raise Fail ("Can only handle .ur files for now") - val () = Elaborate.unifyMore := true + (* val () = Elaborate.unifyMore := true *) (* To reuse Basis and Top *) val () = Elaborate.incremental := true (* Parsing .urp *) @@ -597,20 +704,29 @@ fun calculateFileState (state: state) (fileName: string): (fileState option * Ls end end -fun handleFullDocument (state: state) (toclient: LspSpec.toclient) (documentUri: LspSpec.documentUri) = +fun handleDocumentSavedOrOpened (state: state) (toclient: LspSpec.toclient) (documentUri: LspSpec.documentUri) (textO: string option) = let - val path = #path documentUri - val res = calculateFileState state path + val fileName = #path documentUri + val res = elabFile state fileName + val text = case textO of + NONE => (case SM.find (#fileStates state, fileName) of + NONE => ((#showMessage toclient) ("No previous state for file " ^ fileName) 2; NONE) + | SOME previousState => SOME (#text previousState)) + | SOME text => SOME text in - (case #1 res of - NONE => () - | SOME fs => - stateRef := SOME { urpPath = #urpPath state - , fileStates = SM.insert ( #fileStates state - , path - , fs) - }) ; - #publishDiagnostics toclient { uri = documentUri , diagnostics = #2 res} + case text of + NONE => () + | SOME text => + (case #1 res of + NONE => + insertFileState state fileName { text = text + , envBeforeThisModule = ElabEnv.empty + , decls = [] } + | SOME fs => + (insertFileState state fileName { text = text + , envBeforeThisModule = #envBeforeThisModule fs + , decls = #decls fs }); + #publishDiagnostics toclient { uri = documentUri , diagnostics = #2 res}) end fun scanDir (f: string -> bool) (path: string) = @@ -640,6 +756,19 @@ fun readFile (fileName: string): string = end +(* TODO I couldn't figure out how to print just to a string, so writing to a temp file, then reading it, then deleting it, ... *) +fun ppToString (pp: Print.PD.pp_desc) (width: int): string = + let + val tempfile = OS.FileSys.tmpName () + val outStr = TextIO.openOut tempfile + val outDev = TextIOPP.openOut {dst = outStr, wid = width} + val () = Print.fprint outDev pp + val res = readFile tempfile + val () = TextIO.closeOut outStr + in + res + end + fun handleHover (state: state) (p: LspSpec.hoverReq): LspSpec.hoverResp LspSpec.result = let val fileName = #path (#uri (#textDocument p)) @@ -652,17 +781,203 @@ fun handleHover (state: state) (p: LspSpec.hoverReq): LspSpec.hoverResp LspSpec. val env = #envBeforeThisModule s val decls = #decls s val loc = #position p - val pp = GetInfo.getInfo env (Elab.StrConst decls) fileName { line = #line loc + 1 - , character = #character loc + 1} - (* TODO I couldn't figure out how to print just to a string, so writing to a temp file, then reading it, then deleting it, ... *) - val tempfile = OS.FileSys.tmpName () - val outStr = TextIO.openOut tempfile - val outDev = TextIOPP.openOut {dst = outStr, wid = 70} - val () = Print.fprint outDev pp - val res = readFile tempfile - val () = TextIO.closeOut outStr + val result = GetInfo.getInfo env (Elab.StrConst decls) fileName { line = #line loc + 1 + , character = #character loc + 1} + in + case #smallestgoodpart result of + NONE => LspSpec.Success NONE + | SOME {desc = desc, ...} => + LspSpec.Success (SOME {contents = ppToString desc 70}) + end + end + +fun getCompletionsFromFields (env: ElabEnv.env) (prefix: string) (searchStr: string) (fields: (Elab.con * Elab.con) list): LspSpec.completionItem list = + let + fun mapF (c1, c2) = + case c1 of + (Elab.CName fieldName, _) => + if String.isPrefix searchStr fieldName + then SOME { label = prefix ^ fieldName + , kind = LspSpec.Field + , detail = ppToString (ElabPrint.p_con env c2) 150 + } + else NONE + | _ => NONE + in + List.mapPartial mapF fields + end + +fun getCompletionsFromSignatureItems (env: ElabEnv.env) (prefix: string) (searchStr: string) (items: Elab.sgn_item list): LspSpec.completionItem list = + let + fun mapF item = + case item of + (Elab.SgiVal (name, _, con), _) => + if String.isPrefix searchStr name + then [{ label = prefix ^ name + , kind = LspSpec.Value + , detail = ppToString (ElabPrint.p_con env con) 150 + }] + else [] + | (Elab.SgiCon (name, _, _, con), _) => + if String.isPrefix searchStr name + then [{ label = prefix ^ name + , kind = LspSpec.Variable + , detail = ppToString (ElabPrint.p_con env con) 150 + }] + else [] + | (Elab.SgiDatatype cs, _) => + (List.concat + (List.map (fn (constr as (dtName, n, xs, constrs)) => + (* Copied from elab_print *) + let + val k = (Elab.KType, ErrorMsg.dummySpan) + val env = ElabEnv.pushCNamedAs env dtName n k NONE + val env = List.foldl (fn (x, env) => ElabEnv.pushCRel env dtName k) env xs + in + List.mapPartial (fn (constrName, _, conO) => + if String.isPrefix searchStr constrName + then SOME { label = prefix ^ constrName + , kind = LspSpec.Function + , detail = case conO of + NONE => "Datatype " ^ dtName + | SOME con => "Datatype " ^ dtName ^ " - " ^ ppToString (ElabPrint.p_con env con) 150 + } + else NONE) constrs + end) + cs)) + | (Elab.SgiDatatypeImp _, _) => + (* TODO ??? no idea what this is *) + [] + | (Elab.SgiStr (_, name, _, _), _) => + if String.isPrefix searchStr name + then [{ label = prefix ^ name + , kind = LspSpec.Module + , detail = "" + }] + else [] + | (Elab.SgiClass (name, _, _, con), _) => + if String.isPrefix searchStr name + then [{ label = prefix ^ name + , kind = LspSpec.Class + , detail = ppToString (ElabPrint.p_con env con) 150 + }] + else [] + | _ => [] + in + List.concat (List.map mapF items) + end + +fun findMatchingStringInEnv (env: ElabEnv.env) (str: string): LspSpec.completionItem list = + let + val splitted = Substring.fields (fn c => c = #".") (Substring.full str) + in + case splitted of + (_ :: []) => + if str = "" + then [] + else (List.map (fn (name,con) => + { label = name + , kind = LspSpec.Variable + , detail = ppToString (ElabPrint.p_con env con) 150 + }) + (ElabEnv.matchRelEByPrefix env str + @ ElabEnv.matchNamedEByPrefix env str)) + | (r :: str :: []) => + if Char.isUpper (Substring.sub (r, 0)) + then (* r should be a structure *) + let + (* TODO Perf: first match and then equal is not perfect *) + val foundStrs = ElabEnv.matchStrByPrefix env (Substring.string r) + val filteredStrs = List.filter (fn (name,_) => name = Substring.string r) foundStrs + in + (case List.map (fn (name, (i, sgn)) => (name, ElabEnv.hnormSgn env sgn)) filteredStrs of + [] => [] + | (name, (Elab.SgnConst sgis, _)) :: _ => + getCompletionsFromSignatureItems env (name ^ ".") (Substring.string str) sgis + | _ => []) + end + else (* r should be a record *) + (* TODO is it correct to first try RelE and then NamedE? *) + let + (* TODO Perf: first match and then equal is not perfect *) + val foundRelEs = ElabEnv.matchRelEByPrefix env (Substring.string r) + val foundNamedEs = ElabEnv.matchNamedEByPrefix env (Substring.string r) + val filteredEs = List.filter (fn (name,_) => name = Substring.string r) (foundRelEs @ foundNamedEs) + in + (case List.map (fn (name, c) => (name, ElabOps.reduceCon env c)) filteredEs of + [] => [] + | (name, (Elab.TRecord (Elab.CRecord (_, fields), _), _)) :: _ => + getCompletionsFromFields env (name ^ ".") (Substring.string str) fields + | _ => []) + end + | _ => [] + end + +(* TODO can we use the real parser to figure out what we're typing (exp, con, field, etc) to predict better? *) +fun handleCompletion (state: state) (p: LspSpec.completionReq) = + let + val fileName = #path (#uri (#textDocument p)) + val s = SM.find (#fileStates state, fileName) + in + case s of + NONE => LspSpec.Success { isIncomplete = false, items = []} + | SOME s => + let + val pos = #position p + val line = List.nth (Substring.fields (fn c => c = #"\n") (Substring.full (#text s)), #line pos) + val () = debug ("line" ^ Substring.string line) + val chars = [ (* #".", *) #"(", #")", #"{", #"}", #"[", #"]", #"<", #">", #"-", #"=", #":" + , #" ", #"\n", #"#", #",", #"*", #"\"", #"|", #"&", #"$", #"^", #"+", #";"] + val lineUntilPos = Substring.slice (line, 0, SOME (#character pos)) + val () = debug ("lineUntilPos: \"" ^ Substring.string lineUntilPos ^ "\"") + val searchStr = Substring.string (Substring.taker (fn c => not (List.exists (fn c' => c = c') chars)) lineUntilPos) + val () = debug ("Looking for completions for: \"" ^ searchStr ^ "\"") + val env = #envBeforeThisModule s + val decls = #decls s + val getInfoRes = GetInfo.getInfo env (Elab.StrConst decls) fileName { line = #line pos + 1 + , character = #character pos + 1} + val envOfSmallest = #env (#smallest getInfoRes) + in + LspSpec.Success { isIncomplete = false + , items = findMatchingStringInEnv envOfSmallest searchStr} + end + end + +fun applyContentChange ((c, s): LspSpec.contentChange * string): string = + case (#range c, #rangeLength c) of + (SOME range, SOME _) => + let + val lines = Substring.fields (fn c => c = #"\n") (Substring.full s) + val linesBefore = List.take (lines, #line (#start range)) + val linesAfter = List.drop (lines, #line (#end_ range) + 1) + val startLine = List.nth (lines, #line (#start range)) + val startText = Substring.slice (startLine, 0, SOME (#character (#start range))) + val endLine = List.nth (lines, #line (#end_ range)) + val endText = Substring.triml (#character (#end_ range)) endLine + in + Substring.concatWith "\n" (linesBefore + @ [Substring.full (Substring.concat [startText, Substring.full (#text c), endText])] + @ linesAfter) + end + | _ => + #text c + +fun handleDocumentDidChange (state: state) (toclient: LspSpec.toclient) (p: LspSpec.didChangeParams): unit = + let + val fileName = #path (#uri (#textDocument p)) + val s = SM.find (#fileStates state, fileName) + in + case s of + NONE => + (debug ("Got change event for file that isn't open: " ^ fileName); + (#showMessage toclient) ("Got change event for file that isn't open: " ^ fileName) 1) + | SOME s => + let + val newtext = List.foldl applyContentChange (#text s) (#contentChanges p) in - LspSpec.Success (SOME {contents = res}) + insertFileState state fileName { text = newtext + , decls = #decls s + , envBeforeThisModule = #envBeforeThisModule s} end end @@ -686,14 +1001,17 @@ fun serverLoop () = LspSpec.Success { capabilities = { hoverProvider = true + , completionProvider = SOME { triggerCharacters = ["."]} , textDocumentSync = { openClose = true + , change = 2 , save = SOME { includeText = false } }} } end) handle (Fail str) => LspSpec.Error (~32602, str) , shutdown = fn () => LspSpec.Error (~32002, "Server not initialized") - , textDocument_hover = fn ctx => fn _ => LspSpec.Error (~32002, "Server not initialized") + , textDocument_hover = fn toclient => fn _ => LspSpec.Error (~32002, "Server not initialized") + , textDocument_completion = fn _ => LspSpec.Error (~32002, "Server not initialized") } | LspSpec.Notification n => ()) | SOME state => @@ -702,9 +1020,9 @@ fun serverLoop () = ((LspSpec.handleNotification n { initialized = fn () => () - , textDocument_didOpen = fn ctx => fn p => handleFullDocument state ctx (#uri (#textDocument p)) - , textDocument_didChange = fn ctx => fn didChangeParams => () - , textDocument_didSave = fn ctx => fn p => handleFullDocument state ctx (#uri (#textDocument p)) + , textDocument_didOpen = fn toclient => fn p => handleDocumentSavedOrOpened state toclient (#uri (#textDocument p)) (SOME (#text (#textDocument p))) + , textDocument_didChange = handleDocumentDidChange state + , textDocument_didSave = fn toclient => fn p => handleDocumentSavedOrOpened state toclient (#uri (#textDocument p)) NONE }) handle LspError e => handleLspErrorInNotification e | ex => handleLspErrorInNotification (InternalError (General.exnMessage ex))) @@ -714,7 +1032,8 @@ fun serverLoop () = m { initialize = fn _ => LspSpec.Error (~32600, "Server already initialized") , shutdown = fn () => LspSpec.Success () - , textDocument_hover = fn ctx => fn p => handleHover state p + , 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))) -- cgit v1.2.3 From 1b07e7b1e1b8a81197e98a71baf9c51579f48a3f Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Fri, 13 Dec 2019 19:35:58 +0100 Subject: Fixed JSON parsing: newline escaping --- src/json.sml | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) (limited to 'src/json.sml') diff --git a/src/json.sml b/src/json.sml index 4f604cc4..81d7b8b4 100644 --- a/src/json.sml +++ b/src/json.sml @@ -121,12 +121,18 @@ struct if peek () = #"\\" andalso (String.sub (!inputData, 1)) = #"\"" then (consume "\\\""; pickChars (s ^ "\"")) else - if peek () = #"\\" andalso (String.sub (!inputData, 1)) = #"n" - then (consume "\\n"; pickChars (s ^ "\n")) + if peek () = #"\\" andalso String.sub (!inputData, 1) = #"\\" andalso String.sub (!inputData, 2) = #"n" + then (consume "\\\\n"; pickChars (s ^ "\\n")) else - if peek () = #"\\" andalso (String.sub (!inputData, 1)) = #"r" - then (consume "\\r"; pickChars (s ^ "\r")) - else pickChars (s ^ String.str (take ())) + if peek () = #"\\" andalso (String.sub (!inputData, 1)) = #"n" + then (consume "\\n"; pickChars (s ^ "\n")) + else + if peek () = #"\\" andalso String.sub (!inputData, 1) = #"\\" andalso String.sub (!inputData, 2) = #"r" + then (consume "\\\\r"; pickChars (s ^ "\\r")) + else + if peek () = #"\\" andalso (String.sub (!inputData, 1)) = #"r" + then (consume "\\r"; pickChars (s ^ "\r")) + else pickChars (s ^ String.str (take ())) in pickChars "" end -- cgit v1.2.3