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/lsp.sml | 159 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 159 insertions(+) create mode 100644 src/lsp.sml (limited to 'src/lsp.sml') diff --git a/src/lsp.sml b/src/lsp.sml new file mode 100644 index 00000000..1fd50109 --- /dev/null +++ b/src/lsp.sml @@ -0,0 +1,159 @@ +structure Lsp :> LSP = struct + +fun trim (s: substring): substring = + Substring.dropr + (fn c => c = #" " orelse c = #"\n" orelse c = #"\r") + (Substring.dropl (fn c => c = #" " orelse c = #"\n" orelse c = #"\r") s) + +fun readHeader (): (string * string) option = + let + val line = TextIO.inputLine TextIO.stdIn + in + case line of + NONE => OS.Process.exit OS.Process.success + | SOME str => + let + val (key, value) = Substring.splitl (fn c => c <> #":") (Substring.full str) + in + if Substring.isEmpty (trim value) + then NONE + else SOME ( Substring.string (trim key) + , Substring.string (trim (Substring.dropl (fn c => c = #":") (trim value)))) + end + end + +fun readAllHeaders (l: (string * string) list): (string * string) list = + case readHeader () of + NONE => l + | SOME tup => tup :: readAllHeaders l + +fun getJsonObjectValue (s: string) (l: (string * Json.json) list): Json.json option = + case List.find (fn tup => #1 tup = s ) l of + NONE => NONE + | SOME tup => SOME (#2 tup) + +fun getJsonObjectValue' (s: string) (l: Json.json): Json.json = + case l of + Json.Obj l => + (case getJsonObjectValue s l of + NONE => raise Fail ("Failed to find JSON object key " ^ s) + | SOME v => v) + | a => raise Fail ("Expected JSON object, got: " ^ Json.print a) + +fun parseInt (j: Json.json): int = + case j of + Json.Int i => i + | _ => raise Fail ("Expected JSON int, got: " ^ Json.print j) + +fun parseString (j: Json.json): string = + case j of + Json.String s => s + | _ => raise Fail ("Expected JSON string, got: " ^ Json.print j) + + +fun parseRequest (j: Json.json): {id: Json.json, method: string, params: Json.json} = + let + val id = getJsonObjectValue' "id" j + val method = parseString (getJsonObjectValue' "method" j) + val params = getJsonObjectValue' "params" j + in + {id = id, method = method, params = params} + end + + +type textDocumentIdentifier = + { scheme: string + , authority: string + , path: string + , query: string + , fragment: string + } +fun parseTextDocumentIdentifier (j: Json.json): textDocumentIdentifier = + let + val str = Substring.full (parseString (getJsonObjectValue' "uri" j)) + val (scheme, rest) = Substring.splitl (fn c => c <> #":") str + val (authority, rest) = Substring.splitl (fn c => c <> #"/") (Substring.triml 3 rest (* :// *)) + val (path, rest) = Substring.splitl (fn c => c <> #"?" orelse c <> #"#") (Substring.triml 1 rest (* / *)) + val (query, rest) = if Substring.first rest = SOME #"?" + then Substring.splitl (fn c => c <> #"#") (Substring.triml 1 rest (* ? *)) + else (Substring.full "", rest) + val fragment = if Substring.first rest = SOME #"#" + then (Substring.triml 1 rest (* # *)) + else Substring.full "" + + in + { scheme = Substring.string scheme + , authority = Substring.string authority + , path = Substring.string path + , query = Substring.string query + , fragment = Substring.string fragment + } + end + +type position = { line: int + , character: int + } +fun parsePosition (j: Json.json) = + { line = parseInt (getJsonObjectValue' "line" j) + , character = parseInt (getJsonObjectValue' "character" j) + } + +datatype result = Success of Json.json + | Error of (int * string) + +fun handleHover (params: Json.json): result = + let + val textDocument = parseTextDocumentIdentifier (getJsonObjectValue' "textDocument" params) + val position = parsePosition (getJsonObjectValue' "position" params) + val answer = "" + in + Success (Json.Obj (("contents", Json.String answer) :: [])) + end + +fun serverLoop () = + let + val headers = readAllHeaders [] + val lengthO = List.find (fn (k,v) => k = "Content-Length") headers + val request = case lengthO of + NONE => raise Fail "No header with Content-Length found" + | SOME (k, v) => + case Int.fromString v of + NONE => raise Fail ("Couldn't parse content-length from string: " ^ v) + | SOME i => TextIO.inputN (TextIO.stdIn, i) + (* val parsed = Json.parse (Substring.string (Substring.trimr 1 (Substring.full request))) (* Trimming last newline *) *) + val parsed = Json.parse request + val requestMessage = parseRequest parsed + fun fail (err: (int * string)) = + Json.print (Json.Obj (("id", #id requestMessage) + :: ("error", Json.Obj (("code", Json.Int (#1 err)) + :: ("message", Json.String (#2 err)) + :: [])) + :: [] + )) + val result: result = + case #method requestMessage of + "initialize" => Success (Json.Obj (("capabilities", Json.Obj (("hoverProvider", Json.Bool true) :: [])) :: [])) + | "textDocument/hover" => handleHover (#params requestMessage) + | "shutdown" => Success (Json.Null) + | "exit" => OS.Process.exit OS.Process.success + | method => Error (~32601, "Method not supported: " ^ method) + in + case result of + Success j => TextIO.output (TextIO.stdOut, + Json.print (Json.Obj (("id", #id requestMessage) + :: ("result", j) + :: []))) + | 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) + :: [])) + :: [] + ))) + end + +fun startServer () = + while (1 < 2) do + serverLoop () +end -- cgit v1.2.3 From 26e16f90067ee294d1ccd6341547dbae585cdb3e Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Mon, 9 Dec 2019 11:47:57 +0100 Subject: Refactored LSP into few modules --- src/lsp.sml | 311 ++++++++++++++++++++++++++++++++++++------------------------ 1 file changed, 189 insertions(+), 122 deletions(-) (limited to 'src/lsp.sml') diff --git a/src/lsp.sml b/src/lsp.sml index 1fd50109..2ddce0e3 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -1,141 +1,194 @@ -structure Lsp :> LSP = struct fun trim (s: substring): substring = Substring.dropr - (fn c => c = #" " orelse c = #"\n" orelse c = #"\r") - (Substring.dropl (fn c => c = #" " orelse c = #"\n" orelse c = #"\r") s) + (fn c => c = #" " orelse c = #"\n" orelse c = #"\r") + (Substring.dropl (fn c => c = #" " orelse c = #"\n" orelse c = #"\r") s) -fun readHeader (): (string * string) option = +structure FromJson = struct +fun get (s: string) (l: Json.json): Json.json = let - val line = TextIO.inputLine TextIO.stdIn + fun getJsonObjectValue (s: string) (l: (string * Json.json) list): Json.json option = + case List.find (fn tup => #1 tup = s ) l of + NONE => NONE + | SOME tup => SOME (#2 tup) in - case line of - NONE => OS.Process.exit OS.Process.success - | SOME str => - let - val (key, value) = Substring.splitl (fn c => c <> #":") (Substring.full str) - in - if Substring.isEmpty (trim value) - then NONE - else SOME ( Substring.string (trim key) - , Substring.string (trim (Substring.dropl (fn c => c = #":") (trim value)))) - end + case l of + Json.Obj l => + (case getJsonObjectValue s l of + NONE => raise Fail ("Failed to find JSON object key " ^ s) + | SOME v => v) + | a => raise Fail ("Expected JSON object, got: " ^ Json.print a) end -fun readAllHeaders (l: (string * string) list): (string * string) list = - case readHeader () of - NONE => l - | SOME tup => tup :: readAllHeaders l - -fun getJsonObjectValue (s: string) (l: (string * Json.json) list): Json.json option = - case List.find (fn tup => #1 tup = s ) l of - NONE => NONE - | SOME tup => SOME (#2 tup) - -fun getJsonObjectValue' (s: string) (l: Json.json): Json.json = - case l of - Json.Obj l => - (case getJsonObjectValue s l of - NONE => raise Fail ("Failed to find JSON object key " ^ s) - | SOME v => v) - | a => raise Fail ("Expected JSON object, got: " ^ Json.print a) - -fun parseInt (j: Json.json): int = +fun asInt (j: Json.json): int = case j of Json.Int i => i | _ => raise Fail ("Expected JSON int, got: " ^ Json.print j) -fun parseString (j: Json.json): string = +fun asString (j: Json.json): string = case j of Json.String s => s | _ => raise Fail ("Expected JSON string, got: " ^ Json.print j) +end -fun parseRequest (j: Json.json): {id: Json.json, method: string, params: Json.json} = - let - val id = getJsonObjectValue' "id" j - val method = parseString (getJsonObjectValue' "method" j) - val params = getJsonObjectValue' "params" j - in - {id = id, method = method, params = params} - end - - -type textDocumentIdentifier = - { scheme: string - , authority: string - , path: string - , query: string - , fragment: string - } -fun parseTextDocumentIdentifier (j: Json.json): textDocumentIdentifier = - let - val str = Substring.full (parseString (getJsonObjectValue' "uri" j)) - val (scheme, rest) = Substring.splitl (fn c => c <> #":") str - val (authority, rest) = Substring.splitl (fn c => c <> #"/") (Substring.triml 3 rest (* :// *)) - val (path, rest) = Substring.splitl (fn c => c <> #"?" orelse c <> #"#") (Substring.triml 1 rest (* / *)) - val (query, rest) = if Substring.first rest = SOME #"?" - then Substring.splitl (fn c => c <> #"#") (Substring.triml 1 rest (* ? *)) - else (Substring.full "", rest) - val fragment = if Substring.first rest = SOME #"#" - then (Substring.triml 1 rest (* # *)) - else Substring.full "" - - in - { scheme = Substring.string scheme - , authority = Substring.string authority - , path = Substring.string path - , query = Substring.string query - , fragment = Substring.string fragment - } - end - -type position = { line: int - , character: int - } -fun parsePosition (j: Json.json) = - { line = parseInt (getJsonObjectValue' "line" j) - , character = parseInt (getJsonObjectValue' "character" j) - } - -datatype result = Success of Json.json - | Error of (int * string) - -fun handleHover (params: Json.json): result = - let - val textDocument = parseTextDocumentIdentifier (getJsonObjectValue' "textDocument" params) - val position = parsePosition (getJsonObjectValue' "position" params) - val answer = "" - in - Success (Json.Obj (("contents", Json.String answer) :: [])) - end - -fun serverLoop () = +(* signature LSPSPEC = sig *) +(* type textDocumentIdentifier = *) +(* { scheme: string *) +(* , authority: string *) +(* , path: string *) +(* , query: string *) +(* , fragment: string *) +(* } *) +(* type position = { line: int *) +(* , character: int *) +(* } *) +(* val readRequestFromStdIO: () -> {id: Json.json, method: string, params: Json.json} *) +(* val parseRequest: {id: Json.json, method: string, params: Json.json} -> request *) +(* datatype request = *) +(* end *) + + + +structure LspSpec (* :> LSPSPEC *) = struct + fun readHeader (): (string * string) option = + let + val line = TextIO.inputLine TextIO.stdIn + in + case line of + NONE => OS.Process.exit OS.Process.success + | SOME str => + let + val (key, value) = Substring.splitl (fn c => c <> #":") (Substring.full str) + in + if Substring.isEmpty (trim value) + then NONE + else SOME ( Substring.string (trim key) + , Substring.string (trim (Substring.dropl (fn c => c = #":") (trim value)))) + end + end + + fun readAllHeaders (): (string * string) list = + let + fun doReadAllHeaders (l: (string * string) list): (string * string) list = + case readHeader () of + NONE => l + | SOME tup => tup :: doReadAllHeaders l + + in + doReadAllHeaders [] + end + + fun parseBasicRequest (j: Json.json): {id: Json.json, method: string, params: Json.json} = + let + val id = FromJson.get "id" j + val method = FromJson.asString (FromJson.get "method" j) + val params = FromJson.get "params" j + in + {id = id, method = method, params = params} + end + + type textDocumentIdentifier = + { scheme: string + , authority: string + , path: string + , query: string + , fragment: string + } + fun parseTextDocumentIdentifier (j: Json.json): textDocumentIdentifier = + let + val str = Substring.full (FromJson.asString (FromJson.get "uri" j)) + val (scheme, rest) = Substring.splitl (fn c => c <> #":") str + val (authority, rest) = Substring.splitl (fn c => c <> #"/") (Substring.triml 3 rest (* :// *)) + val (path, rest) = Substring.splitl (fn c => c <> #"?" orelse c <> #"#") (Substring.triml 1 rest (* / *)) + val (query, rest) = if Substring.first rest = SOME #"?" + then Substring.splitl (fn c => c <> #"#") (Substring.triml 1 rest (* ? *)) + else (Substring.full "", rest) + val fragment = if Substring.first rest = SOME #"#" + then (Substring.triml 1 rest (* # *)) + else Substring.full "" + + in + { scheme = Substring.string scheme + , authority = Substring.string authority + , path = Substring.string path + , query = Substring.string query + , fragment = Substring.string fragment + } + end + + type position = { line: int + , character: int + } + fun parsePosition (j: Json.json) = + { line = FromJson.asInt (FromJson.get "line" j) + , character = FromJson.asInt (FromJson.get "character" j) + } + + + fun readRequestFromStdIO (): {id: Json.json, method: string, params: Json.json} = + let + val headers = readAllHeaders () + val lengthO = List.find (fn (k,v) => k = "Content-Length") headers + val request = case lengthO of + NONE => raise Fail "No header with Content-Length found" + | SOME (k, v) => + case Int.fromString v of + NONE => raise Fail ("Couldn't parse content-length from string: " ^ v) + | SOME i => TextIO.inputN (TextIO.stdIn, i) + val parsed = Json.parse request + in + parseBasicRequest parsed + end + + fun parseHoverReq (params: Json.json): { textDocument: textDocumentIdentifier , position: position } = + { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" params) + , position = parsePosition (FromJson.get "position" params) + } + + fun printHoverResponse (resp: {contents: string}): Json.json = + Json.Obj (("contents", Json.String (#contents resp)) :: []) + + datatype 'a result = + Success of 'a + | Error of (int * string) + + fun mapResult (f: 'a -> 'b) (a: 'a result): 'b result = + case a of + Success contents => Success (f contents) + | Error e => Error e + type handlers = + { initialize: unit -> { capabilities: {hoverProvider: bool}} result + , shutdown: unit -> unit result + , textDocument_hover: { textDocument: textDocumentIdentifier + , position: position } + -> {contents: string} result + } + + fun handleRequest + (requestMessage: {id: Json.json, method: string, params: Json.json}) + (handlers: handlers) + : unit = let - val headers = readAllHeaders [] - val lengthO = List.find (fn (k,v) => k = "Content-Length") headers - val request = case lengthO of - NONE => raise Fail "No header with Content-Length found" - | SOME (k, v) => - case Int.fromString v of - NONE => raise Fail ("Couldn't parse content-length from string: " ^ v) - | SOME i => TextIO.inputN (TextIO.stdIn, i) - (* val parsed = Json.parse (Substring.string (Substring.trimr 1 (Substring.full request))) (* Trimming last newline *) *) - val parsed = Json.parse request - val requestMessage = parseRequest parsed - fun fail (err: (int * string)) = - Json.print (Json.Obj (("id", #id requestMessage) - :: ("error", Json.Obj (("code", Json.Int (#1 err)) - :: ("message", Json.String (#2 err)) - :: [])) - :: [] - )) - val result: result = + val result: Json.json result = case #method requestMessage of - "initialize" => Success (Json.Obj (("capabilities", Json.Obj (("hoverProvider", Json.Bool true) :: [])) :: [])) - | "textDocument/hover" => handleHover (#params requestMessage) - | "shutdown" => Success (Json.Null) - | "exit" => OS.Process.exit OS.Process.success + "initialize" => + mapResult + (fn res => Json.Obj (("capabilities", Json.Obj (("hoverProvider", Json.Bool (#hoverProvider (#capabilities res))) + :: [])) + :: [])) + ((#initialize handlers) ()) + | "textDocument/hover" => + mapResult + printHoverResponse + ((#textDocument_hover handlers) + (parseHoverReq (#params requestMessage))) + | "shutdown" => + mapResult + (fn () => Json.Null) + ((#shutdown handlers) ()) + | "exit" => + OS.Process.exit OS.Process.success | method => Error (~32601, "Method not supported: " ^ method) in case result of @@ -152,8 +205,22 @@ fun serverLoop () = :: [] ))) end + +end + +structure Lsp :> LSP = struct + +fun serverLoop () = + let + val requestMessage = LspSpec.readRequestFromStdIO () + in + LspSpec.handleRequest + requestMessage + { initialize = fn () => LspSpec.Success {capabilities = {hoverProvider = true}} + , shutdown = fn () => LspSpec.Success () + , textDocument_hover = fn _ => LspSpec.Success {contents = ""} + } + end -fun startServer () = - while (1 < 2) do - serverLoop () +fun startServer () = while true do serverLoop () end -- cgit v1.2.3 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/lsp.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 d53867eae4608bce7ecd39c488705339f4fabd0a Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Mon, 9 Dec 2019 21:03:05 +0100 Subject: Added some LSP notifications support --- .envrc | 2 +- src/lsp.sml | 139 ++++++++++++++++++++++++++++++++++++++++++++++-------------- 2 files changed, 109 insertions(+), 32 deletions(-) (limited to 'src/lsp.sml') diff --git a/.envrc b/.envrc index 4a4726a5..051d09d2 100644 --- a/.envrc +++ b/.envrc @@ -1 +1 @@ -use_nix +eval "$(lorri direnv)" diff --git a/src/lsp.sml b/src/lsp.sml index f3fed67c..d2c380c6 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -22,6 +22,11 @@ fun asString (j: Json.json): string = 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) end structure LspSpec (* :> LSPSPEC *) = struct @@ -70,16 +75,16 @@ structure LspSpec (* :> LSPSPEC *) = struct | SOME id => RequestMessage {id = id, method = method, params = params} end - type textDocumentIdentifier = + type documentUri = { scheme: string , authority: string , path: string , query: string , fragment: string } - fun parseTextDocumentIdentifier (j: Json.json): textDocumentIdentifier = + fun parseDocumentUri (str: string): documentUri = let - val str = Substring.full (FromJson.asString (FromJson.get "uri" j)) + 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 (* / *)) @@ -99,6 +104,32 @@ structure LspSpec (* :> LSPSPEC *) = struct } end + 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 } @@ -122,16 +153,58 @@ structure LspSpec (* :> LSPSPEC *) = struct parseMessage parsed end - fun parseHoverReq (params: Json.json): { textDocument: textDocumentIdentifier , position: position } = + 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: {contents: string} option): Json.json = + 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 didChangeParams = { textDocument: versionedTextDocumentIdentifier } + fun parseDidChangeParams (params: Json.json): didChangeParams = + { textDocument = parseVersionedTextDocumentIdentifier (FromJson.get "textDocument" params) + (* , contentChanges = ... *) + } + + type didSaveParams = { textDocument: textDocumentIdentifier } + fun parseDidSaveParams (params: Json.json): didSaveParams = + { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" params) + (* , text = ... *) + } + + type initializeResponse = { capabilities: + { hoverProvider: bool + , textDocumentSync: { openClose: bool + , save: { includeText: bool} option + } + }} + fun printInitializeResponse (res: initializeResponse) = + Json.Obj [("capabilities", + let + val capabilities = #capabilities res + in + Json.Obj [ ("hoverProvider", Json.Bool (#hoverProvider capabilities)) + , ("textDocumentSync", + let + val textDocumentSync = #textDocumentSync capabilities + in + Json.Obj [ ("openClose", Json.Bool (#openClose 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) @@ -140,14 +213,11 @@ structure LspSpec (* :> LSPSPEC *) = struct case a of Success contents => Success (f contents) | Error e => Error e + type context = { showMessage: string -> int -> unit} type messageHandlers = - { initialize: unit -> { capabilities: {hoverProvider: bool}} result + { initialize: unit -> initializeResponse result , shutdown: unit -> unit result - , textDocument_hover: - { showMessage: string -> int -> unit} - -> { textDocument: textDocumentIdentifier - , position: position } - -> ({contents: string} option) result + , textDocument_hover: context -> hoverReq -> hoverResp result } fun handleMessage @@ -165,7 +235,7 @@ structure LspSpec (* :> LSPSPEC *) = struct case #method requestMessage of "initialize" => mapResult - (fn res => Json.Obj [("capabilities", Json.Obj [("hoverProvider", Json.Bool (#hoverProvider (#capabilities res)))])]) + printInitializeResponse ((#initialize handlers) ()) | "textDocument/hover" => mapResult @@ -212,15 +282,20 @@ structure LspSpec (* :> LSPSPEC *) = struct type notificationHandlers = { initialized: unit -> unit + , textDocument_didOpen: didOpenParams -> unit + , textDocument_didChange: didChangeParams -> unit + , textDocument_didSave: didSaveParams -> unit } fun handleNotification (notification: {method: string, params: Json.json}) (handlers: notificationHandlers) = case #method notification of "initialized" => (#initialized handlers) () + | "textDocument/didOpen" => (#textDocument_didOpen handlers) (parseDidOpenParams (#params notification)) + | "textDocument/didChange" => (#textDocument_didChange handlers) (parseDidChangeParams (#params notification)) + | "textDocument/didSave" => (#textDocument_didSave handlers) (parseDidSaveParams (#params notification)) | m => (TextIO.output ( TextIO.stdErr, "Notification method not supported: " ^ m); TextIO.flushOut TextIO.stdErr) - end @@ -234,24 +309,26 @@ fun serverLoop () = in (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.handleNotification + n + { initialized = fn () => () + , textDocument_didOpen = fn didOpenParams => () + , textDocument_didChange = fn didChangeParams => () + , textDocument_didSave = fn didChangeParams => () + } | 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 - } - ) + LspSpec.handleMessage + m + { initialize = fn () => LspSpec.Success + { capabilities = + { hoverProvider = true + , textDocumentSync = { openClose = true + , save = SOME { includeText = false } + }} + } + , 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 -- cgit v1.2.3 From 98ebd4d0b10165693a205d30399149e32954b833 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Tue, 10 Dec 2019 11:11:11 +0100 Subject: Started work on keeping some state in LSP server --- src/lsp.sml | 140 +++++++++++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 111 insertions(+), 29 deletions(-) (limited to 'src/lsp.sml') diff --git a/src/lsp.sml b/src/lsp.sml index d2c380c6..cff30d5e 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -27,6 +27,12 @@ fun asOptionalInt (j: Json.json): int option = 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 @@ -179,12 +185,20 @@ structure LspSpec (* :> LSPSPEC *) = struct { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" params) (* , text = ... *) } - + type initializeParams = + { rootUri: documentUri option } + fun parseInitializeParams (j: Json.json) = + { rootUri = + Option.map + parseDocumentUri + (FromJson.asOptionalString (FromJson.get "rootUri" j)) + } type initializeResponse = { capabilities: { hoverProvider: bool - , textDocumentSync: { openClose: bool - , save: { includeText: bool} option - } + , textDocumentSync: + { openClose: bool + , save: { includeText: bool } option + } }} fun printInitializeResponse (res: initializeResponse) = Json.Obj [("capabilities", @@ -215,7 +229,7 @@ structure LspSpec (* :> LSPSPEC *) = struct | Error e => Error e type context = { showMessage: string -> int -> unit} type messageHandlers = - { initialize: unit -> initializeResponse result + { initialize: initializeParams -> initializeResponse result , shutdown: unit -> unit result , textDocument_hover: context -> hoverReq -> hoverResp result } @@ -236,7 +250,8 @@ structure LspSpec (* :> LSPSPEC *) = struct "initialize" => mapResult printInitializeResponse - ((#initialize handlers) ()) + ((#initialize handlers) + (parseInitializeParams (#params requestMessage))) | "textDocument/hover" => mapResult printHoverResponse @@ -301,35 +316,102 @@ end structure Lsp :> LSP = struct +structure SK = struct + type ord_key = string + val compare = String.compare +end +structure SM = BinaryMapFn(SK) + +type fileState = + { envOfPreviousModules : ElabEnv.env + , decls : Elab.decl list + } +type state = + { rootUri : LspSpec.documentUri + , fileStates : fileState SM.map + } +val stateRef = ref (NONE: state option) + +(* Throws Fail if can't init *) +fun initState (initParams: LspSpec.initializeParams): state = + { rootUri = case #rootUri initParams of + NONE => raise Fail "Failed to initialize: no rootUri" + | SOME a => a + , fileStates = SM.empty + } +fun calculateFileState (state: state) (fileName: string): fileState = + { envOfPreviousModules = ElabEnv.empty + , decls = [] + } + fun serverLoop () = let val requestMessage = LspSpec.readRequestFromStdIO () handle ex => (TextIO.output (TextIO.stdErr, General.exnMessage ex ^ "\n"); TextIO.flushOut TextIO.stdErr ; raise ex) + val state = !stateRef in - (case requestMessage of - LspSpec.Notification n => - LspSpec.handleNotification - n - { initialized = fn () => () - , textDocument_didOpen = fn didOpenParams => () - , textDocument_didChange = fn didChangeParams => () - , textDocument_didSave = fn didChangeParams => () - } - | LspSpec.RequestMessage m => - LspSpec.handleMessage - m - { initialize = fn () => LspSpec.Success - { capabilities = - { hoverProvider = true - , textDocumentSync = { openClose = true - , save = SOME { includeText = false } - }} - } - , 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) + case state of + NONE => + (case requestMessage of + LspSpec.RequestMessage m => + 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 + , 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") + } + | LspSpec.Notification n => ()) + | SOME state => + (case requestMessage of + LspSpec.Notification n => + LspSpec.handleNotification + n + { initialized = fn () => () + , textDocument_didOpen = fn didOpenParams => + let + val path = #path (#uri (#textDocument didOpenParams)) + val fileState = calculateFileState state (path) + in + stateRef := SOME { rootUri = #rootUri state + , fileStates = SM.insert ( #fileStates state + , path + , fileState) + } + end + , textDocument_didChange = fn didChangeParams => () + , textDocument_didSave = fn didSaveParams => + let + val path = #path (#uri (#textDocument didSaveParams)) + val fileState = calculateFileState state (path) + in + stateRef := SOME { rootUri = #rootUri state + , fileStates = SM.insert ( #fileStates state + , path + , fileState) + } + end + } + | 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 => (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 053783525d8365b8a498ac38942d44f4669d6a54 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Tue, 10 Dec 2019 20:21:35 +0100 Subject: First version of calculateFileState --- src/elaborate.sig | 14 +++++ src/lsp.sml | 149 +++++++++++++++++++++++++++++++++++++++++++++++++----- 2 files changed, 150 insertions(+), 13 deletions(-) (limited to 'src/lsp.sml') diff --git a/src/elaborate.sig b/src/elaborate.sig index 03359814..88ea068f 100644 --- a/src/elaborate.sig +++ b/src/elaborate.sig @@ -53,4 +53,18 @@ signature ELABORATE = sig , sgn: Elab.sgn } -> (Elab.decl list * ElabEnv.env) + val elabSgn: (ElabEnv.env * Disjoint.env) + -> Source.sgn + -> (Elab.sgn * Disjoint.goal list) + + datatype constraint = + Disjoint of Disjoint.goal + | TypeClass of ElabEnv.env * Elab.con * Elab.exp option ref * ErrorMsg.span + + val elabStr: (ElabEnv.env * Disjoint.env) + -> Source.str + -> (Elab.str * Elab.sgn * constraint list) + + val subSgn: ElabEnv.env -> ErrorMsg.span -> Elab.sgn -> Elab.sgn -> unit + end diff --git a/src/lsp.sml b/src/lsp.sml index cff30d5e..89a0e4b2 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -1,3 +1,5 @@ +structure C = Compiler + fun trim (s: substring): substring = Substring.dropr (fn c => c = #" " orelse c = #"\n" orelse c = #"\r") @@ -327,22 +329,143 @@ type fileState = , decls : Elab.decl list } type state = - { rootUri : LspSpec.documentUri + { urpPath : string , fileStates : fileState SM.map } val stateRef = ref (NONE: state option) +fun scanDir (f: string -> bool) (path: string) = + let + val dir = OS.FileSys.openDir path + fun doScanDir acc = + case OS.FileSys.readDir dir of + NONE => (OS.FileSys.closeDir dir; acc) + | SOME fname => + (if f fname + then doScanDir (fname :: acc) + else doScanDir acc) + in + doScanDir [] + end + (* Throws Fail if can't init *) fun initState (initParams: LspSpec.initializeParams): state = - { rootUri = case #rootUri initParams of - NONE => raise Fail "Failed to initialize: no rootUri" - | SOME a => a - , fileStates = SM.empty - } + let + val rootPath = case #rootUri initParams of + NONE => raise Fail "No rootdir found" + | SOME a => #path a + 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 + | many => raise Fail ("Found multiple .urp files in path " ^ rootPath) + , fileStates = SM.empty + } + end + +fun addSgnToEnv (env: ElabEnv.env) (sgn: Source.sgn_item list) (fileName: string) (addUnprefixed: bool): ElabEnv.env = + let + val moduleName = C.moduleOf fileName + val (sgn, gs) = Elaborate.elabSgn (env, Disjoint.empty) (Source.SgnConst sgn, { file = fileName + , first = ErrorMsg.dummyPos + , last = ErrorMsg.dummyPos }) + val () = case gs of + [] => () + | _ => (app (fn (_, env, _, c1, c2) => + Print.prefaces "Unresolved" + [("c1", ElabPrint.p_con env c1), + ("c2", ElabPrint.p_con env c2)]) gs; + raise Fail ("Unresolved disjointness constraints in " ^ moduleName ^ " at " ^ fileName)) (* TODO Not sure if this is needed for all signatures or only for Basis *) + val (env', n) = ElabEnv.pushStrNamed env moduleName sgn + val (_, env') = if addUnprefixed + then Elaborate.dopen env' {str = n, strs = [], sgn = sgn} + else ([], env) + in + env' + end + fun calculateFileState (state: state) (fileName: string): fileState = - { envOfPreviousModules = ElabEnv.empty - , decls = [] - } + 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)) + | _ => () + val parsedUrss = List.map (fn entry => + let + val fileName = entryInUrpToFileName 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)} + 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")) + 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) + 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 + val (str, sgn', gs) = + Elaborate.elabStr + (envBeforeThisFile, Disjoint.empty) + (Source.StrConst parsedUr, {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}) + + (* TODO definitily 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 + in + { envOfPreviousModules = envBeforeThisFile + , decls = case str of + (Elab.StrConst decls, _) => decls + | _ => raise Fail ("Impossible: Source.StrConst did not become Elab.StrConst after elaboration") + } + end fun serverLoop () = let @@ -383,9 +506,9 @@ fun serverLoop () = , textDocument_didOpen = fn didOpenParams => let val path = #path (#uri (#textDocument didOpenParams)) - val fileState = calculateFileState state (path) + val fileState = calculateFileState state path in - stateRef := SOME { rootUri = #rootUri state + stateRef := SOME { urpPath = #urpPath state , fileStates = SM.insert ( #fileStates state , path , fileState) @@ -395,9 +518,9 @@ fun serverLoop () = , textDocument_didSave = fn didSaveParams => let val path = #path (#uri (#textDocument didSaveParams)) - val fileState = calculateFileState state (path) + val fileState = calculateFileState state path in - stateRef := SOME { rootUri = #rootUri state + stateRef := SOME { urpPath = #urpPath state , fileStates = SM.insert ( #fileStates state , path , fileState) -- cgit v1.2.3 From 3515286a783fb1eb38acc001d23389dd67fdc910 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Tue, 10 Dec 2019 21:12:59 +0100 Subject: First publishDiagnostics implementation --- src/errormsg.sig | 3 ++ src/errormsg.sml | 8 ++- src/lsp.sml | 145 +++++++++++++++++++++++++++++++++++++------------------ 3 files changed, 109 insertions(+), 47 deletions(-) (limited to 'src/lsp.sml') diff --git a/src/errormsg.sig b/src/errormsg.sig index 4cf8b50a..1fa4013c 100644 --- a/src/errormsg.sig +++ b/src/errormsg.sig @@ -58,4 +58,7 @@ signature ERROR_MSG = sig val error : string -> unit val errorAt : span -> string -> unit val errorAt' : int * int -> string -> unit + val readErrorLog: unit -> + { span: span + , message: string } list end diff --git a/src/errormsg.sml b/src/errormsg.sml index eee20768..d40789ed 100644 --- a/src/errormsg.sml +++ b/src/errormsg.sml @@ -88,6 +88,9 @@ fun spanOf (pos1, pos2) = {file = !file, val errors = ref false +val errorLog = ref ([]: { span: span + , message: string } list) +fun readErrorLog () = !errorLog val structuresCurrentlyElaborating: ((string * bool) list) ref = ref nil fun startElabStructure s = @@ -106,7 +109,7 @@ fun stopElabStructureAndGetErrored s = fun resetStructureTracker () = structuresCurrentlyElaborating := [] -fun resetErrors () = errors := false +fun resetErrors () = (errors := false; errorLog := []) fun anyErrors () = !errors fun error s = (TextIO.output (TextIO.stdErr, s); TextIO.output1 (TextIO.stdErr, #"\n"); @@ -120,6 +123,9 @@ fun errorAt (span : span) s = (TextIO.output (TextIO.stdErr, #file span); TextIO.output (TextIO.stdErr, ": (to "); TextIO.output (TextIO.stdErr, posToString (#last span)); TextIO.output (TextIO.stdErr, ") "); + errorLog := ({ span = span + , message = s + } :: !errorLog); error s) fun errorAt' span s = errorAt (spanOf span) s diff --git a/src/lsp.sml b/src/lsp.sml index 89a0e4b2..976faa25 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -5,6 +5,9 @@ fun trim (s: substring): substring = (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 get (s: string) (l: Json.json): Json.json = case l of @@ -111,6 +114,12 @@ structure LspSpec (* :> LSPSPEC *) = struct , 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 = @@ -145,6 +154,13 @@ structure LspSpec (* :> LSPSPEC *) = struct { 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 printRange (r: range): Json.json = Json.Obj [ ("start", printPosition (#start r)) + , ("end", printPosition (#end_ r))] fun readRequestFromStdIO (): message = let @@ -195,6 +211,26 @@ structure LspSpec (* :> LSPSPEC *) = struct 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 initializeResponse = { capabilities: { hoverProvider: bool , textDocumentSync: @@ -229,24 +265,27 @@ structure LspSpec (* :> LSPSPEC *) = struct case a of Success contents => Success (f contents) | Error e => Error e - type context = { showMessage: string -> int -> unit} + type toclient = { showMessage: string -> int -> unit + , publishDiagnostics: publishDiagnosticsParams -> unit } type messageHandlers = { initialize: initializeParams -> initializeResponse result , shutdown: unit -> unit result - , textDocument_hover: context -> hoverReq -> hoverResp result + , textDocument_hover: toclient -> hoverReq -> hoverResp result } + 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)) + val toclient: toclient = {showMessage = showMessage, publishDiagnostics = publishDiagnostics} + fun handleMessage (requestMessage: {id: Json.json, method: string, params: Json.json}) (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" => @@ -258,7 +297,7 @@ structure LspSpec (* :> LSPSPEC *) = struct mapResult printHoverResponse ((#textDocument_hover handlers) - {showMessage = showMessage} + toclient (parseHoverReq (#params requestMessage))) | "shutdown" => mapResult @@ -299,18 +338,19 @@ structure LspSpec (* :> LSPSPEC *) = struct type notificationHandlers = { initialized: unit -> unit - , textDocument_didOpen: didOpenParams -> unit - , textDocument_didChange: didChangeParams -> unit - , textDocument_didSave: didSaveParams -> unit + , textDocument_didOpen: toclient -> didOpenParams -> unit + , textDocument_didChange: toclient -> didChangeParams -> unit + , textDocument_didSave: toclient -> didSaveParams -> unit } fun handleNotification (notification: {method: string, params: Json.json}) (handlers: notificationHandlers) - = case #method notification of + = + case #method notification of "initialized" => (#initialized handlers) () - | "textDocument/didOpen" => (#textDocument_didOpen handlers) (parseDidOpenParams (#params notification)) - | "textDocument/didChange" => (#textDocument_didChange handlers) (parseDidChangeParams (#params notification)) - | "textDocument/didSave" => (#textDocument_didSave handlers) (parseDidSaveParams (#params notification)) + | "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) @@ -385,7 +425,8 @@ fun addSgnToEnv (env: ElabEnv.env) (sgn: Source.sgn_item list) (fileName: string env' end -fun calculateFileState (state: state) (fileName: string): fileState = +(* 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? *) val () = if (OS.Path.ext fileName = SOME "ur") @@ -426,12 +467,13 @@ fun calculateFileState (state: state) (fileName: string): fileState = SOME (valOf (C.run (C.transform C.parseUrs "parseUrs") (fileName ^ "s"))) else 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 definitily not sure about this one, just copied from "top" processing *) + (* 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) => @@ -459,12 +501,43 @@ fun calculateFileState (state: state) (fileName: string): fileState = , {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 () in - { envOfPreviousModules = envBeforeThisFile - , decls = case str of - (Elab.StrConst decls, _) => decls - | _ => raise Fail ("Impossible: Source.StrConst did not become Elab.StrConst after elaboration") - } + ({ envOfPreviousModules = envBeforeThisFile + , decls = case str of + (Elab.StrConst decls, _) => decls + | _ => raise Fail ("Impossible: Source.StrConst did not become Elab.StrConst after elaboration") + }, + List.map + (fn err => { range = { start = { line = #line (#first (#span err)) + , character = #char (#first (#span err)) + } + , end_ = { line = #line (#last (#span err)) + , character = #char (#last (#span err)) + } + } + , severity = 1 + , source = "UrWeb" + , message = #message err + } + ) + errors + ) + end + +fun handleFullDocument (state: state) (toclient: LspSpec.toclient) (documentUri: LspSpec.documentUri) = + let + val path = #path documentUri + val res = calculateFileState state path + in + stateRef := SOME { urpPath = #urpPath state + , fileStates = SM.insert ( #fileStates state + , path + , #1 res) + }; + case #2 res of + [] => () + | diags => #publishDiagnostics toclient { uri = documentUri , diagnostics = diags} end fun serverLoop () = @@ -503,29 +576,9 @@ fun serverLoop () = LspSpec.handleNotification n { initialized = fn () => () - , textDocument_didOpen = fn didOpenParams => - let - val path = #path (#uri (#textDocument didOpenParams)) - val fileState = calculateFileState state path - in - stateRef := SOME { urpPath = #urpPath state - , fileStates = SM.insert ( #fileStates state - , path - , fileState) - } - end - , textDocument_didChange = fn didChangeParams => () - , textDocument_didSave = fn didSaveParams => - let - val path = #path (#uri (#textDocument didSaveParams)) - val fileState = calculateFileState state path - in - stateRef := SOME { urpPath = #urpPath state - , fileStates = SM.insert ( #fileStates state - , path - , fileState) - } - end + , 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.RequestMessage m => LspSpec.handleMessage -- 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/lsp.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 96c72b6bd8bbb2e31da5664172c05a1bcfb41b64 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Tue, 10 Dec 2019 22:48:36 +0100 Subject: Add parse error comment --- src/lsp.sml | 1 + 1 file changed, 1 insertion(+) (limited to 'src/lsp.sml') diff --git a/src/lsp.sml b/src/lsp.sml index 175a71ee..658ca7a6 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -443,6 +443,7 @@ fun addSgnToEnv (env: ElabEnv.env) (sgn: Source.sgn_item list) (fileName: string env' end +(* TODO: Any parse error -> valOf fails, throws and server crashes *) fun calculateFileState (state: state) (fileName: string): (fileState * LspSpec.diagnostic list) = let (* TODO Optim: cache parsed urp file? *) -- 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/lsp.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 25b0685cefe772c73562665a4cc8d2d40e5ff600 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Wed, 11 Dec 2019 13:58:01 +0100 Subject: Use elabFile completely instead of rebuilding it partially --- src/compiler.sml | 2 +- src/elaborate.sig | 5 +++- src/elaborate.sml | 4 ++- src/lsp.sml | 73 ++++++++++++++++++++++++++----------------------------- 4 files changed, 42 insertions(+), 42 deletions(-) (limited to 'src/lsp.sml') diff --git a/src/compiler.sml b/src/compiler.sml index fab939f9..ab7b86b4 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1283,7 +1283,7 @@ val elaborate = { in Elaborate.elabFile basis (OS.FileSys.modTime basisF) topStr topSgn (if Time.< (tm1, tm2) then tm2 else tm1) - ElabEnv.empty file + ElabEnv.empty (fn env => env) file end, print = ElabPrint.p_file ElabEnv.empty } diff --git a/src/elaborate.sig b/src/elaborate.sig index 88ea068f..d6747241 100644 --- a/src/elaborate.sig +++ b/src/elaborate.sig @@ -29,7 +29,10 @@ signature ELABORATE = sig val elabFile : Source.sgn_item list -> Time.time -> Source.decl list -> Source.sgn_item list -> Time.time - -> ElabEnv.env -> Source.file -> Elab.file + -> ElabEnv.env + -> (ElabEnv.env -> ElabEnv.env) (* Adapt env after stdlib but before elaborate *) + -> Source.file + -> Elab.file val resolveClass : ElabEnv.env -> Elab.con -> Elab.exp option diff --git a/src/elaborate.sml b/src/elaborate.sml index d5e190fa..85234775 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -4760,7 +4760,7 @@ and elabStr (env, denv) (str, loc) = fun resolveClass env = E.resolveClass (hnormCon env) (consEq env dummy) env -fun elabFile basis basis_tm topStr topSgn top_tm env file = +fun elabFile basis basis_tm topStr topSgn top_tm env changeEnv file = let val () = ModDb.snapshot () val () = ErrorMsg.resetStructureTracker () @@ -4857,6 +4857,8 @@ fun elabFile basis basis_tm topStr topSgn top_tm env file = val (ds', env') = dopen env' {str = top_n, strs = [], sgn = topSgn} + val env' = changeEnv env' + fun elabDecl' x = (resetKunif (); resetCunif (); diff --git a/src/lsp.sml b/src/lsp.sml index 34209231..b5a92683 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -417,9 +417,7 @@ end structure SM = BinaryMapFn(SK) type fileState = - { envOfPreviousModules : ElabEnv.env - , decls : Elab.decl list - } + { decls : Elab.decl list } type state = { urpPath : string , fileStates : fileState SM.map @@ -498,6 +496,8 @@ fun calculateFileState (state: state) (fileName: string): (fileState option * Ls then () else raise Fail ("Can only handle .ur files for now") val () = Elaborate.unifyMore := true + (* To reuse Basis and Top *) + 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))) @@ -531,28 +531,35 @@ fun calculateFileState (state: state) (fileName: string): (fileState option * Ls } end) modulesBeforeThisFile - (* Parsing Basis and Top .urs *) + (* Parsing Basis and Top *) + val basisF = Settings.libFile "basis.urs" + val topF = Settings.libFile "top.urs" + val topF' = Settings.libFile "top.ur" + + val tm1 = OS.FileSys.modTime topF + val tm2 = OS.FileSys.modTime topF' + 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"))) + case C.run (C.transform C.parseUrs "parseUrs") basisF of + NONE => raise LspError (InternalError ("Failed to parse basis.urs file at " ^ basisF)) | 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"))) + case C.run (C.transform C.parseUrs "parseUrs") topF of + NONE => raise LspError (InternalError ("Failed to parse top.urs file at " ^ topF)) | 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 parsedTopUr = + case C.run (C.transform C.parseUr "parseUr") topF' of + NONE => raise LspError (InternalError ("Failed to parse top.ur file at " ^ topF')) + | SOME a => a + (* Parsing .ur and .urs of current file *) - val (parsedUrs: (Source.sgn_item list) option) = + val (parsedUrs: Source.sgn option) = (if OS.FileSys.access (fileName ^ "s", []) then case C.run (C.transform C.parseUrs "parseUrs") (fileName ^ "s") of NONE => NONE - | SOME a => SOME a + | SOME a => SOME ( Source.SgnConst a + , {file = fileName ^ "s", first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}) else NONE) handle ex => NONE val () = ErrorMsg.resetErrors () @@ -562,34 +569,22 @@ fun calculateFileState (state: state) (fileName: string): (fileState option * Ls case parsedUrO of NONE => (* Parse error *) (NONE, List.map errorToDiagnostic (ErrorMsg.readErrorLog ())) | SOME parsedUr => - (* .ur file found -> typecheck *) + (* Parsing of .ur succeeded *) 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) + val loc = {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos} + val res = Elaborate.elabFile + parsedBasisUrs tm1 parsedTopUr parsedTopUrs tm2 ElabEnv.empty + (* Adding urs's of previous modules to env *) + (fn envB => List.foldl (fn (sgn, env) => addSgnToEnv env (#parsed sgn) (#fileName sgn) false) envB parsedUrss) + [( Source.DStr (C.moduleOf fileName, parsedUrs, NONE, (Source.StrConst parsedUr, loc), false) + , loc )] (* report back errors (as Diagnostics) *) val errors = ErrorMsg.readErrorLog () - val decls = case str of - (Elab.StrConst decls, _) => decls + val decls = case List.last res of + (Elab.DStr (_, _, _, (Elab.StrConst decls, _)), _) => decls | _ => raise Fail ("Impossible: Source.StrConst did not become Elab.StrConst after elaboration") in - (SOME { envOfPreviousModules = envBeforeThisFile - , decls = decls - }, + (SOME { decls = decls }, List.map errorToDiagnostic errors) end end -- cgit v1.2.3 From 9b00dc724363ac7b0a31687f14cc3bb2f2460f9b Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Wed, 11 Dec 2019 22:56:29 +0100 Subject: Integrated getInfo into LSP --- src/getinfo.sig | 7 +- src/getinfo.sml | 353 ++++++++++++++++++++++++----------------------------- src/lsp.sml | 69 ++++++++++- src/main.mlton.sml | 6 - 4 files changed, 230 insertions(+), 205 deletions(-) (limited to 'src/lsp.sml') diff --git a/src/getinfo.sig b/src/getinfo.sig index 317b7e79..334e19f1 100644 --- a/src/getinfo.sig +++ b/src/getinfo.sig @@ -26,6 +26,11 @@ *) signature GET_INFO = sig - val getInfo: string (* file:row:col *) -> Print.PD.pp_desc + val getInfo: + ElabEnv.env -> + Elab.str' -> + string (* fileName *) -> + { line: int , character: int} -> + Print.PD.pp_desc end diff --git a/src/getinfo.sml b/src/getinfo.sml index 37c50928..7925aba3 100644 --- a/src/getinfo.sml +++ b/src/getinfo.sml @@ -73,198 +73,163 @@ fun getSpan (f: item * E.env) = | Str s => #2 s | Decl d => #2 d -fun getInfo' file row col = - if not (!Elaborate.incremental) - then P.PD.string "ERROR: urweb daemon is needed to use typeOf command" - else - case ModDb.lookupModAndDepsIncludingErrored (Compiler.moduleOf file) of - NONE => P.PD.string ("ERROR: No module found: " ^ Compiler.moduleOf file) - | SOME (modDecl, deps) => - let - val () = U.mliftConInCon := E.mliftConInCon - - (* Adding signature of dependencies to environment *) - val env = List.foldl (fn (d, e) => E.declBinds e d) E.empty deps - - (* Adding previous declarations in file to environment *) - (* "open " statements are already translated during elaboration *) - (* They get added to the env here "unprefixed" *) - val env = - case #1 modDecl of - L.DStr (name, _, sgn, str) => - (case #1 str of - L.StrConst decls => - List.foldl (fn (d, env) => - if #line (#first (#2 d)) <= row - andalso #char (#first (#2 d)) <= col - then E.declBinds env d - else env) env decls - | _ => env) - | L.DFfiStr _ => env - | _ => env - - (* Basis and Top need to be added to the env explicitly *) - val env = - case ModDb.lookupModAndDepsIncludingErrored "Top" of - NONE => raise Fail "ERROR: Top module not found in ModDb" - | SOME ((L.DStr (_, top_n, topSgn, topStr), _), _) => - #2 (Elaborate.dopen env {str = top_n, strs = [], sgn = topSgn}) - | _ => raise Fail "ERROR: Impossible" - val env = - case ModDb.lookupModAndDepsIncludingErrored "Basis" of - NONE => raise Fail "ERROR: Top module not found in ModDb" - | SOME ((L.DFfiStr (_, basis_n, sgn), _), _) => - #2 (Elaborate.dopen env {str = basis_n, strs = [], sgn = sgn}) - | _ => raise Fail "ERROR: Impossible" - - (* Just use ElabPrint functions. *) - (* These are better for compiler error message, 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 *) - (* TODO Rename? *) - fun printGoodPart env f span = - (case f of - Exp (L.EPrim p, _) => - SOME (P.box [Prim.p_t p, - P.PD.string ": ", - P.PD.string (case p of - Prim.Int _ => "int" - | Prim.Float _ => "float" - | Prim.String _ => "string" - | Prim.Char _ => "char")]) - | Exp (L.ERel n, _) => - SOME ((let val found = E.lookupERel env n - in - P.box [ P.PD.string (#1 found) - , P.PD.string ": " - , ElabPrint.p_con env (#2 found)] - end) - handle E.UnboundRel _ => P.PD.string ("UNBOUND_REL" ^ Int.toString n)) - | Exp (L.ENamed n, _) => - SOME ((let val found = E.lookupENamed env n - in - P.box [ P.PD.string (#1 found) - , P.PD.string ": " - , ElabPrint.p_con env (#2 found)] - end) - handle E.UnboundNamed _ => P.PD.string ("UNBOUND_NAMED" ^ Int.toString n)) - | Exp (L.EModProj ( m1 (* number (= "name") of top level module *) - , ms (* names of submodules - possibly none *) - , x (* identifier *)), loc) => - SOME (let - val (m1name, m1sgn) = E.lookupStrNamed env m1 - val (str, sgn) = foldl (fn (m, (str, sgn)) => - case E.projectStr env {sgn = sgn, str = str, field = m} of - NONE => raise Fail ("Couldn't find Structure: " ^ m) - | SOME sgn => ((L.StrProj (str, m), loc), sgn)) - ((L.StrVar m1, loc), m1sgn) - ms - val t = case E.projectVal env {sgn = sgn, str = str, field = x} of - NONE => raise Fail ("Couldn't find identifier: " ^ x) - | SOME t => t - in - P.box [ P.p_list_sep (P.PD.string ".") P.PD.string (m1name :: ms @ [x]) - , P.PD.string ": " - , ElabPrint.p_con env t - ] - end - handle E.UnboundNamed _ => P.PD.string ("Module not found: " ^ Int.toString m1)) - | Exp e => NONE - | Kind k => NONE - | Con c => NONE - | Sgn_item si => NONE - | Sgn s => NONE - | Str s => NONE - | Decl d => NONE) - - fun add env item span acc = - if not (isPosIn file row col span) - then - acc - else - let - val smallest = - if isSmallerThan span (#span (#smallest acc)) - then {span = span, item = item, env = env} - else #smallest acc - val smallestgoodpart = - case #smallestgoodpart acc of - NONE => - (case printGoodPart env item span of - NONE => NONE - | SOME desc => SOME (desc, span)) - | SOME (desc', span') => - if isSmallerThan span span' - then - (case printGoodPart env item span of - NONE => SOME (desc', span') - | SOME desc => SOME (desc, span)) - else SOME (desc', span') - in - {smallest = smallest, smallestgoodpart = smallestgoodpart} - end - - (* Look for item at input position *) - (* We're looking for two things simultaneously: *) - (* 1. The "smallest" part, ie. the one of which the source span is the smallest *) - (* 2. The "smallestgoodpart" part, ie. the one of which the source span is the smallest AND has a special case in printGoodPart *) - (* If we end up with a smallestgoodpart, we'll show that one since that one is probably more useful *) - (* TODO source spans of XML and SQL sources are weird and you end *) - (* up with eg: a span from eg 1-5 and another from 2-6, makes no sense? *) - (* That's one of the reasons why we're searching for the two things mentioned above *) - val result = - U.Decl.foldB - { kind = fn (env, (k, span), acc) => add env (Kind (k, span)) span acc, - con = fn (env, (k, span), acc) => add env (Con (k, span)) span acc, - exp = fn (env, (k, span), acc) => add env (Exp (k, span)) span acc, - sgn_item = fn (env, (k, span), acc) => add env (Sgn_item (k, span)) span acc, - sgn = fn (env, (k, span), acc) => add env (Sgn (k, span)) span acc, - str = fn (env, (k, span), acc) => add env (Str (k, span)) span acc, - decl = fn (env, (k, span), acc) => add env (Decl (k, span)) span acc, - bind = fn (env, binder) => - case binder of - U.Decl.RelK x => E.pushKRel env x - | U.Decl.RelC (x, k) => E.pushCRel env x k - | U.Decl.NamedC (x, n, k, co) => E.pushCNamedAs env x n k co - | U.Decl.RelE (x, c) => E.pushERel env x c - | U.Decl.NamedE (x, c) => #1 (E.pushENamed env x c) - | U.Decl.Str (x, n, sgn) => #1 (E.pushStrNamed env x sgn) - | U.Decl.Sgn (x, n, sgn) => #1 (E.pushSgnNamed env x sgn) - } - env - { smallestgoodpart = NONE - , smallest = { item = Decl (#1 modDecl, { file = file - , first = { line = 0, char = 0} - , last = { line = 99999, char = 0} }) - , span = { file = file - , first = { line = 0, char = 0} - , last = { line = 99999, char = 0} } - , env = env } - } - modDecl - in - case #smallestgoodpart result of - NONE => printLiterally (#smallest result) - | SOME (desc, span) => desc - end - -fun getInfo loc = - case String.tokens (fn ch => ch = #":") loc of - file :: rowStr :: colStr :: nil => - (case (Int.fromString rowStr, Int.fromString colStr) of - (SOME row, SOME col) => getInfo' file row col - | _ => P.PD.string "ERROR: Wrong typeOf input format, should be ") - | _ => P.PD.string "ERROR: Wrong typeOf input format, should be " +fun getInfo env str fileName {line = row, character = col} = + let + val () = U.mliftConInCon := E.mliftConInCon + + (* Adding previous declarations in file to environment *) + (* "open " statements are already translated during elaboration *) + (* They get added to the env here "unprefixed" *) + val env = (case str of + L.StrConst decls => + List.foldl (fn (d, env) => + if #line (#first (#2 d)) <= row + andalso #char (#first (#2 d)) <= col + then E.declBinds env d + 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 *) + (* TODO Rename? *) + fun printGoodPart env f span = + (case f of + Exp (L.EPrim p, _) => + SOME (P.box [Prim.p_t p, + P.PD.string ": ", + P.PD.string (case p of + Prim.Int _ => "int" + | Prim.Float _ => "float" + | Prim.String _ => "string" + | Prim.Char _ => "char")]) + | Exp (L.ERel n, _) => + SOME ((let val found = E.lookupERel env n + in + P.box [ P.PD.string (#1 found) + , P.PD.string ": " + , ElabPrint.p_con env (#2 found)] + end) + handle E.UnboundRel _ => P.PD.string ("UNBOUND_REL" ^ Int.toString n)) + | Exp (L.ENamed n, _) => + SOME ((let val found = E.lookupENamed env n + in + P.box [ P.PD.string (#1 found) + , P.PD.string ": " + , ElabPrint.p_con env (#2 found)] + end) + handle E.UnboundNamed _ => P.PD.string ("UNBOUND_NAMED" ^ Int.toString n)) + | Exp (L.EModProj ( m1 (* number (= "name") of top level module *) + , ms (* names of submodules - possibly none *) + , x (* identifier *)), loc) => + SOME (let + val (m1name, m1sgn) = E.lookupStrNamed env m1 + val (str, sgn) = foldl (fn (m, (str, sgn)) => + case E.projectStr env {sgn = sgn, str = str, field = m} of + NONE => raise Fail ("Couldn't find Structure: " ^ m) + | SOME sgn => ((L.StrProj (str, m), loc), sgn)) + ((L.StrVar m1, loc), m1sgn) + ms + val t = case E.projectVal env {sgn = sgn, str = str, field = x} of + NONE => raise Fail ("Couldn't find identifier: " ^ x) + | SOME t => t + in + P.box [ P.p_list_sep (P.PD.string ".") P.PD.string (m1name :: ms @ [x]) + , P.PD.string ": " + , ElabPrint.p_con env t + ] + end + handle E.UnboundNamed _ => P.PD.string ("Module not found: " ^ Int.toString m1)) + | Exp e => NONE + | Kind k => NONE + | Con c => NONE + | Sgn_item si => NONE + | Sgn s => NONE + | Str s => NONE + | Decl d => NONE) + + fun add env item span acc = + if not (isPosIn fileName row col span) + then + acc + else + let + val smallest = + if isSmallerThan span (#span (#smallest acc)) + then {span = span, item = item, env = env} + else #smallest acc + val smallestgoodpart = + case #smallestgoodpart acc of + NONE => + (case printGoodPart env item span of + NONE => NONE + | SOME desc => SOME (desc, span)) + | SOME (desc', span') => + if isSmallerThan span span' + then + (case printGoodPart env item span of + NONE => SOME (desc', span') + | SOME desc => SOME (desc, span)) + else SOME (desc', span') + in + {smallest = smallest, smallestgoodpart = smallestgoodpart} + end + + (* Look for item at input position *) + (* We're looking for two things simultaneously: *) + (* 1. The "smallest" part, ie. the one of which the source span is the smallest *) + (* 2. The "smallestgoodpart" part, ie. the one of which the source span is the smallest AND has a special case in printGoodPart *) + (* If we end up with a smallestgoodpart, we'll show that one since that one is probably more useful *) + (* TODO source spans of XML and SQL sources are weird and you end *) + (* up with eg: a span from eg 1-5 and another from 2-6, makes no sense? *) + (* That's one of the reasons why we're searching for the two things mentioned above *) + val result = + U.Decl.foldB + { kind = fn (env, (k, span), acc) => add env (Kind (k, span)) span acc, + con = fn (env, (k, span), acc) => add env (Con (k, span)) span acc, + exp = fn (env, (k, span), acc) => add env (Exp (k, span)) span acc, + sgn_item = fn (env, (k, span), acc) => add env (Sgn_item (k, span)) span acc, + sgn = fn (env, (k, span), acc) => add env (Sgn (k, span)) span acc, + str = fn (env, (k, span), acc) => add env (Str (k, span)) span acc, + decl = fn (env, (k, span), acc) => add env (Decl (k, span)) span acc, + bind = fn (env, binder) => + case binder of + U.Decl.RelK x => E.pushKRel env x + | U.Decl.RelC (x, k) => E.pushCRel env x k + | U.Decl.NamedC (x, n, k, co) => E.pushCNamedAs env x n k co + | U.Decl.RelE (x, c) => E.pushERel env x c + | U.Decl.NamedE (x, c) => #1 (E.pushENamed env x c) + | U.Decl.Str (x, n, sgn) => #1 (E.pushStrNamed env x sgn) + | U.Decl.Sgn (x, n, sgn) => #1 (E.pushSgnNamed env x sgn) + } + env + { smallestgoodpart = NONE + , smallest = { item = Str (str, { file = fileName + , first = { line = 0, char = 0} + , last = { line = 99999, char = 0} }) + , span = { file = fileName + , first = { line = 0, char = 0} + , last = { line = 99999, char = 0} } + , env = env } + } + ( 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 + end end diff --git a/src/lsp.sml b/src/lsp.sml index b5a92683..cfdec863 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -417,7 +417,8 @@ end structure SM = BinaryMapFn(SK) type fileState = - { decls : Elab.decl list } + { envBeforeThisModule: ElabEnv.env + , decls : Elab.decl list } type state = { urpPath : string , fileStates : fileState SM.map @@ -572,10 +573,17 @@ fun calculateFileState (state: state) (fileName: string): (fileState option * Ls (* Parsing of .ur succeeded *) let val loc = {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos} + val envBeforeThisModule = ref ElabEnv.empty val res = Elaborate.elabFile parsedBasisUrs tm1 parsedTopUr parsedTopUrs tm2 ElabEnv.empty (* Adding urs's of previous modules to env *) - (fn envB => List.foldl (fn (sgn, env) => addSgnToEnv env (#parsed sgn) (#fileName sgn) false) envB parsedUrss) + (fn envB => + let + val newEnv = List.foldl (fn (sgn, env) => addSgnToEnv env (#parsed sgn) (#fileName sgn) false) envB parsedUrss + in + (envBeforeThisModule := newEnv; newEnv) + end + ) [( Source.DStr (C.moduleOf fileName, parsedUrs, NONE, (Source.StrConst parsedUr, loc), false) , loc )] (* report back errors (as Diagnostics) *) @@ -584,7 +592,7 @@ fun calculateFileState (state: state) (fileName: string): (fileState option * Ls (Elab.DStr (_, _, _, (Elab.StrConst decls, _)), _) => decls | _ => raise Fail ("Impossible: Source.StrConst did not become Elab.StrConst after elaboration") in - (SOME { decls = decls }, + (SOME { envBeforeThisModule = !envBeforeThisModule, decls = decls }, List.map errorToDiagnostic errors) end end @@ -605,6 +613,59 @@ fun handleFullDocument (state: state) (toclient: LspSpec.toclient) (documentUri: #publishDiagnostics toclient { uri = documentUri , diagnostics = #2 res} end +fun scanDir (f: string -> bool) (path: string) = + let + val dir = OS.FileSys.openDir path + fun doScanDir acc = + case OS.FileSys.readDir dir of + NONE => (OS.FileSys.closeDir dir; acc) + | SOME fname => + (if f fname + then doScanDir (fname :: acc) + else doScanDir acc) + in + doScanDir [] + end + +fun readFile (fileName: string): string = + let + val str = TextIO.openIn fileName + fun doReadFile acc = + case TextIO.inputLine str of + NONE => acc + | SOME str => (str ^ "\n" ^ acc) + val res = doReadFile "" + in + (TextIO.closeIn str; res) + end + + +fun handleHover (state: state) (p: LspSpec.hoverReq): LspSpec.hoverResp LspSpec.result = + let + val fileName = #path (#uri (#textDocument p)) + val s = SM.find (#fileStates state, fileName) + in + case s of + NONE => LspSpec.Success NONE + | SOME s => + let + 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 + in + LspSpec.Success (SOME {contents = res}) + end + end + fun serverLoop () = let val requestMessage = @@ -653,7 +714,7 @@ fun serverLoop () = m { initialize = fn _ => LspSpec.Error (~32600, "Server already initialized") , shutdown = fn () => LspSpec.Success () - , textDocument_hover = fn ctx => fn _ => LspSpec.Success NONE + , textDocument_hover = fn ctx => fn p => handleHover state p }) handle LspError e => handleLspErrorInRequest (#id m) e | ex => handleLspErrorInRequest (#id m) (InternalError (General.exnMessage ex))) diff --git a/src/main.mlton.sml b/src/main.mlton.sml index 1747d702..9042307a 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -141,10 +141,6 @@ fun oneRun args = fun printModuleOf fname = print_and_exit (Compiler.moduleOf fname) () - fun getInfo loc = - (Print.print (GetInfo.getInfo loc); - raise Code OS.Process.success) - fun add_class (class, num) = case Int.fromString num of NONE => raise Fail ("Invalid limit number '" ^ num ^ "'") @@ -251,8 +247,6 @@ fun oneRun args = NONE), ("moduleOf", ONE ("", printModuleOf), SOME "print module name of and exit"), - ("getInfo", ONE ("", getInfo), - SOME "print info of expression at and exit"), ("startLspServer", ZERO Lsp.startServer, SOME "Start Language Server Protocol server"), ("noEmacs", set_true Demo.noEmacs, NONE), -- 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/lsp.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 679977b188fc9bbfd1b311e895ca48454876b7f4 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Thu, 12 Dec 2019 22:50:35 +0100 Subject: Tweaks to autocompletion of datatype constructors --- src/lsp.sml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'src/lsp.sml') diff --git a/src/lsp.sml b/src/lsp.sml index aaef422c..7aa7a98b 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -832,15 +832,15 @@ fun getCompletionsFromSignatureItems (env: ElabEnv.env) (prefix: string) (search 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 + val env = List.foldl (fn (x, env) => ElabEnv.pushCRel env x 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 + NONE => dtName + | SOME con => ppToString (ElabPrint.p_con env con) 150 ^ " -> " ^ dtName } else NONE) constrs end) -- cgit v1.2.3 From a16c342d75f96a530da30e85465328306f5412ef Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Thu, 12 Dec 2019 22:55:24 +0100 Subject: Last tweak to datatype constructors autocomplete --- src/lsp.sml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'src/lsp.sml') diff --git a/src/lsp.sml b/src/lsp.sml index 7aa7a98b..50eea923 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -833,14 +833,15 @@ fun getCompletionsFromSignatureItems (env: ElabEnv.env) (prefix: string) (search 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 x k) env xs + val typeVarsString = List.foldl (fn (x, acc) => acc ^ " " ^ x) "" 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 => dtName - | SOME con => ppToString (ElabPrint.p_con env con) 150 ^ " -> " ^ dtName + NONE => dtName ^ typeVarsString + | SOME con => ppToString (ElabPrint.p_con env con) 150 ^ " -> " ^ dtName ^ typeVarsString } else NONE) constrs end) -- cgit v1.2.3 From 171ba38b23b6acfdb28a0b591d26d3e4bb87458b Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Fri, 13 Dec 2019 08:56:39 +0100 Subject: Added textDocument_didClose --- src/lsp.sml | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) (limited to 'src/lsp.sml') diff --git a/src/lsp.sml b/src/lsp.sml index 50eea923..2c9aab56 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -226,6 +226,10 @@ structure LspSpec (* :> LSPSPEC *) = struct { 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) = @@ -457,6 +461,7 @@ structure LspSpec (* :> LSPSPEC *) = struct , 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}) @@ -467,6 +472,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)) + | "textDocument/didClose" => (#textDocument_didClose handlers) toclient (parseDidCloseParams (#params notification)) | m => debug ("Notification method not supported: " ^ m) end @@ -982,6 +988,16 @@ fun handleDocumentDidChange (state: state) (toclient: LspSpec.toclient) (p: LspS end end +fun handleDocumentDidClose (state: state) (toclient: LspSpec.toclient) (p: LspSpec.didCloseParams): unit = + let + val fileName = #path (#uri (#textDocument p)) + val s = SM.find (#fileStates state, fileName) + in + stateRef := SOME { urpPath = #urpPath state + , fileStates = (#1 (SM.remove (#fileStates state, fileName))) handle ex => #fileStates state + } + end + fun serverLoop () = let val requestMessage = @@ -1024,6 +1040,7 @@ fun serverLoop () = , 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 + , textDocument_didClose = fn toclient => fn p => handleDocumentDidClose state toclient p }) handle LspError e => handleLspErrorInNotification e | ex => handleLspErrorInNotification (InternalError (General.exnMessage ex))) -- cgit v1.2.3 From 8ef0d043574638a48c71b7c4c9844fc05973f13d Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Fri, 13 Dec 2019 09:58:15 +0100 Subject: Added completion suggestions for types --- src/elab_env.sig | 4 ++-- src/elab_env.sml | 20 ++++++++++++++----- src/lsp.sml | 58 +++++++++++++++++++++++++++++++++++++------------------- 3 files changed, 56 insertions(+), 26 deletions(-) (limited to 'src/lsp.sml') diff --git a/src/elab_env.sig b/src/elab_env.sig index 55909b53..fb95d68e 100644 --- a/src/elab_env.sig +++ b/src/elab_env.sig @@ -61,6 +61,7 @@ signature ELAB_ENV = sig val lookupCNamed : env -> int -> string * Elab.kind * Elab.con option val lookupC : env -> string -> Elab.kind var + val matchCByPrefix: env -> string -> (string * Elab.kind) list val pushDatatype : env -> int -> string list -> (string * int * Elab.con option) list -> env type datatyp @@ -85,8 +86,7 @@ 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 matchEByPrefix: env -> string -> (string * Elab.con) list val lookupE : env -> string -> Elab.con var diff --git a/src/elab_env.sml b/src/elab_env.sml index e79b665d..34071664 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -404,6 +404,14 @@ fun lookupC (env : env) x = | SOME (Rel' x) => Rel x | SOME (Named' x) => Named x +fun matchCByPrefix (env: env) (prefix: string): (string * kind) list = + List.mapPartial (fn (name, value) => if String.isPrefix prefix name + then case value of + Rel' (_, x) => SOME (name, x) + | Named' (_, x) => SOME (name, x) + else NONE) + (SM.listItemsi (#renameC env)) + fun pushDatatype (env : env) n xs xncs = let val dk = U.classifyDatatype xncs @@ -932,11 +940,13 @@ 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 matchEByPrefix (env: env) (prefix: string): (string * con) list = + List.mapPartial (fn (name, value) => if String.isPrefix prefix name + then case value of + Rel' (_, x) => SOME (name, x) + | Named' (_, x) => SOME (name, x) + else NONE) + (SM.listItemsi (#renameE env)) fun checkENamed (env : env) n = Option.isSome (IM.find (#namedE env, n)) diff --git a/src/lsp.sml b/src/lsp.sml index 2c9aab56..2d80479b 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -762,7 +762,7 @@ 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, ... *) +(* TODO PERF BIG 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 () @@ -827,7 +827,7 @@ fun getCompletionsFromSignatureItems (env: ElabEnv.env) (prefix: string) (search | (Elab.SgiCon (name, _, _, con), _) => if String.isPrefix searchStr name then [{ label = prefix ^ name - , kind = LspSpec.Variable + , kind = LspSpec.Value , detail = ppToString (ElabPrint.p_con env con) 150 }] else [] @@ -874,6 +874,7 @@ fun getCompletionsFromSignatureItems (env: ElabEnv.env) (prefix: string) (search List.concat (List.map mapF items) end +(* TODO TOCHECK look at con's to specify "kind" more accurately *) fun findMatchingStringInEnv (env: ElabEnv.env) (str: string): LspSpec.completionItem list = let val splitted = Substring.fields (fn c => c = #".") (Substring.full str) @@ -882,18 +883,35 @@ fun findMatchingStringInEnv (env: ElabEnv.env) (str: string): LspSpec.completion (_ :: []) => 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)) + else + let + val matchingEs = ElabEnv.matchEByPrefix env str (* function params, let bindings and top-level bindings. Should we discern between Rel and Named? *) + val expressionCompletions = List.map (fn (name,con) => + { label = name + , kind = LspSpec.Value + , detail = ppToString (ElabPrint.p_con env con) 150 + }) matchingEs + val matchingStrs = ElabEnv.matchStrByPrefix env str + val structureCompletions = List.map (fn (name,(_,sgn)) => + { label = name + , kind = LspSpec.Module + , detail = "" + }) matchingStrs + val matchingCons = ElabEnv.matchCByPrefix env str + val conCompletions = List.map (fn (name,kind) => + { label = name + , kind = LspSpec.Constructor (* TODO probably wrong... *) + , detail = ppToString (ElabPrint.p_kind env kind) 150 + }) matchingCons + in + expressionCompletions @ structureCompletions @ conCompletions + end | (r :: str :: []) => if Char.isUpper (Substring.sub (r, 0)) - then (* r should be a structure *) + then + (* Completing STRUCTURE *) let - (* TODO Perf: first match and then equal is not perfect *) + (* TODO PERF SMALL: 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 @@ -903,13 +921,13 @@ fun findMatchingStringInEnv (env: ElabEnv.env) (str: string): LspSpec.completion 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? *) + else + (* Completing RECORD *) + (* TODO TOCHECK 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) + (* TODO PERF SMALL: first match and then equal is not perfect *) + val foundEs = ElabEnv.matchEByPrefix env (Substring.string r) + val filteredEs = List.filter (fn (name,_) => name = Substring.string r) foundEs in (case List.map (fn (name, c) => (name, ElabOps.reduceCon env c)) filteredEs of [] => [] @@ -917,10 +935,12 @@ fun findMatchingStringInEnv (env: ElabEnv.env) (str: string): LspSpec.completion getCompletionsFromFields env (name ^ ".") (Substring.string str) fields | _ => []) end - | _ => [] + | _ => + (* TODO NOTIMPLEMENTED submodules / nested records *) + [] end -(* TODO can we use the real parser to figure out what we're typing (exp, con, field, etc) to predict better? *) +(* TODO IDEA 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)) -- cgit v1.2.3 From f2ada9d9761c3aa7575571fd93629b79350a1425 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Fri, 13 Dec 2019 10:58:11 +0100 Subject: Trial version of completing table fields --- src/elab_env.sml | 7 +++---- src/lsp.sml | 13 ++++++++++++- 2 files changed, 15 insertions(+), 5 deletions(-) (limited to 'src/lsp.sml') diff --git a/src/elab_env.sml b/src/elab_env.sml index 34071664..f492bc94 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -940,13 +940,12 @@ fun lookupENamed (env : env) n = NONE => raise UnboundNamed n | SOME x => x +(* TODO Why does this work better than using #renameE? *) fun matchEByPrefix (env: env) (prefix: string): (string * con) list = List.mapPartial (fn (name, value) => if String.isPrefix prefix name - then case value of - Rel' (_, x) => SOME (name, x) - | Named' (_, x) => SOME (name, x) + then SOME (name, value) else NONE) - (SM.listItemsi (#renameE env)) + (#relE env @ IM.listItems (#namedE env)) fun checkENamed (env : env) n = Option.isSome (IM.find (#namedE env, n)) diff --git a/src/lsp.sml b/src/lsp.sml index 2d80479b..920f9f35 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -931,8 +931,19 @@ fun findMatchingStringInEnv (env: ElabEnv.env) (str: string): LspSpec.completion in (case List.map (fn (name, c) => (name, ElabOps.reduceCon env c)) filteredEs of [] => [] - | (name, (Elab.TRecord (Elab.CRecord (_, fields), _), _)) :: _ => + | (name, (Elab.TRecord (Elab.CRecord (_, fields), l2_), l1_)) :: _ => getCompletionsFromFields env (name ^ ".") (Substring.string str) fields + | (name, (* TODO this doesn't always work. I've only managed to get it working for tables in a different module *) + ( ( Elab.CApp + ( ( (Elab.CApp + ( ( Elab.CModProj (_, _, "sql_table") + , l4_) + , ( Elab.CRecord (_, fields) + , l3_))) + , l2_) + , _)) + , l1_)) :: _ => + (debug "!!"; getCompletionsFromFields env (name ^ ".") (Substring.string str) fields) | _ => []) end | _ => -- cgit v1.2.3 From be644b0be6acd3cdeb957d46e9477ea3e16599ba Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Fri, 13 Dec 2019 11:32:02 +0100 Subject: Moved json and lsp code into seperate modules --- src/fromjson.sig | 8 + src/fromjson.sml | 35 ++++ src/lsp.sml | 537 ++----------------------------------------------------- src/lspspec.sml | 447 +++++++++++++++++++++++++++++++++++++++++++++ src/sources | 5 + 5 files changed, 506 insertions(+), 526 deletions(-) create mode 100644 src/fromjson.sig create mode 100644 src/fromjson.sml create mode 100644 src/lspspec.sml (limited to 'src/lsp.sml') diff --git a/src/fromjson.sig b/src/fromjson.sig new file mode 100644 index 00000000..3fdc1a89 --- /dev/null +++ b/src/fromjson.sig @@ -0,0 +1,8 @@ +signature FROMJSON = sig + val getO: string -> Json.json -> Json.json option + val get: string -> Json.json -> Json.json + val asInt: Json.json -> int + val asString: Json.json -> string + val asOptionalInt: Json.json -> int option + val asOptionalString: Json.json -> string option +end diff --git a/src/fromjson.sml b/src/fromjson.sml new file mode 100644 index 00000000..6a9bd71b --- /dev/null +++ b/src/fromjson.sml @@ -0,0 +1,35 @@ +structure FromJson :> FROMJSON = struct +fun getO (s: string) (l: Json.json): Json.json option = + case l of + Json.Obj pairs => + (case List.find (fn tup => #1 tup = s) pairs of + NONE => NONE + | SOME tup => SOME (#2 tup)) + | _ => raise Fail ("Expected JSON object, got: " ^ Json.print l) +fun get (s: string) (l: Json.json): Json.json = + (case getO s l of + NONE => raise Fail ("Failed to find JSON object key " ^ s ^ " in " ^ Json.print l) + | SOME a => a) + +fun asInt (j: Json.json): int = + case j of + Json.Int i => i + | _ => raise Fail ("Expected JSON int, got: " ^ Json.print j) + +fun asString (j: Json.json): string = + case j of + Json.String s => s + | _ => raise Fail ("Expected JSON string, got: " ^ Json.print j) + +fun asOptionalInt (j: Json.json): int option = + case j of + Json.Null => NONE + | Json.Int i => SOME i + | _ => raise Fail ("Expected JSON int or null, got: " ^ Json.print j) + +fun asOptionalString (j: Json.json): string option = + case j of + Json.Null => NONE + | Json.String s => SOME s + | _ => raise Fail ("Expected JSON string or null, got: " ^ Json.print j) +end diff --git a/src/lsp.sml b/src/lsp.sml index 920f9f35..d902fed4 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -1,519 +1,8 @@ structure C = Compiler -fun debug (str: string): unit = - (TextIO.output (TextIO.stdErr, str ^ "\n\n"); TextIO.flushOut TextIO.stdErr) - -fun trim (s: substring): substring = - Substring.dropr - (fn c => c = #" " orelse c = #"\n" orelse c = #"\r") - (Substring.dropl (fn c => c = #" " orelse c = #"\n" orelse c = #"\r") s) - -fun joinStr (sep: string) (strs: string list): string = - List.foldl (fn (str, acc) => if acc = "" then str else acc ^ sep ^ str) "" strs - -structure FromJson = struct -fun getO (s: string) (l: Json.json): Json.json option = - case l of - Json.Obj pairs => - (case List.find (fn tup => #1 tup = s) pairs of - NONE => NONE - | SOME tup => SOME (#2 tup)) - | _ => raise Fail ("Expected JSON object, got: " ^ Json.print l) -fun get (s: string) (l: Json.json): Json.json = - (case getO s l of - NONE => raise Fail ("Failed to find JSON object key " ^ s ^ " in " ^ Json.print l) - | SOME a => a) - -fun asInt (j: Json.json): int = - case j of - Json.Int i => i - | _ => raise Fail ("Expected JSON int, got: " ^ Json.print j) - -fun asString (j: Json.json): string = - case j of - Json.String s => s - | _ => raise Fail ("Expected JSON string, got: " ^ Json.print j) - -fun asOptionalInt (j: Json.json): int option = - case j of - Json.Null => NONE - | Json.Int i => SOME i - | _ => raise Fail ("Expected JSON int or null, got: " ^ Json.print j) - -fun asOptionalString (j: Json.json): string option = - case j of - Json.Null => NONE - | Json.String s => SOME s - | _ => raise Fail ("Expected JSON string or null, got: " ^ Json.print j) -end - -structure LspSpec (* :> LSPSPEC *) = struct - fun readHeader (): (string * string) option = - let - val line = TextIO.inputLine TextIO.stdIn - in - case line of - NONE => OS.Process.exit OS.Process.success - | SOME str => - if Substring.isEmpty (trim (Substring.full str)) - then NONE - else - let - val (key, value) = Substring.splitl (fn c => c <> #":") (Substring.full str) - in - if Substring.isEmpty (trim value) - then raise Fail ("Failed to parse LSP header: Line is not empty but is also not a valid header: " ^ str) - else SOME ( Substring.string (trim key) - , Substring.string (trim (Substring.dropl (fn c => c = #":") (trim value)))) - end - end - - fun readAllHeaders (): (string * string) list = - let - fun doReadAllHeaders (l: (string * string) list): (string * string) list = - case readHeader () of - NONE => l - | SOME tup => tup :: doReadAllHeaders l - - in - doReadAllHeaders [] - end - datatype message = - RequestMessage of { id: Json.json, method: string, params: Json.json} - | Notification of { method: string, params: Json.json} - fun parseMessage (j: Json.json): message = - let - val id = SOME (FromJson.get "id" j) - handle ex => NONE - val method = FromJson.asString (FromJson.get "method" j) - val params = FromJson.get "params" j - in - case id of - NONE => Notification {method = method, params = params} - | SOME id => RequestMessage {id = id, method = method, params = params} - end - - type documentUri = - { scheme: string - , authority: string - , path: string - , query: string - , fragment: string - } - fun parseDocumentUri (str: string): documentUri = - let - val str = Substring.full str - val (scheme, rest) = Substring.splitl (fn c => c <> #":") str - val (authority, rest) = Substring.splitl (fn c => c <> #"/") (Substring.triml 3 rest (* :// *)) - val (path, rest) = Substring.splitl (fn c => c <> #"?" orelse c <> #"#") rest - val (query, rest) = if Substring.first rest = SOME #"?" - then Substring.splitl (fn c => c <> #"#") (Substring.triml 1 rest (* ? *)) - else (Substring.full "", rest) - val fragment = if Substring.first rest = SOME #"#" - then (Substring.triml 1 rest (* # *)) - else Substring.full "" - - in - { scheme = Substring.string scheme - , authority = Substring.string authority - , path = Substring.string path - , query = Substring.string query - , fragment = Substring.string fragment - } - end - fun printDocumentUri (d: documentUri) = - (#scheme d) ^ "://" ^ - (#authority d) ^ - (#path d) ^ - (if #query d <> "" then "?" ^ #query d else "") ^ - (if #fragment d <> "" then "#" ^ #fragment d else "") - - type textDocumentIdentifier = { uri: documentUri} - fun parseTextDocumentIdentifier (j: Json.json): textDocumentIdentifier = - { uri = parseDocumentUri (FromJson.asString (FromJson.get "uri" j))} - - type versionedTextDocumentIdentifier = - { uri: documentUri - , version: int option - } - fun parseVersionedTextDocumentIdentifier (j: Json.json): versionedTextDocumentIdentifier = - { uri = parseDocumentUri (FromJson.asString (FromJson.get "uri" j)) - , version = FromJson.asOptionalInt (FromJson.get "version" j) - } - - type textDocumentItem = { - uri: documentUri, - languageId: string, - version: int, (* The version number of this document (it will increase after each change, including undo/redo). *) - text: string - } - fun parseTextDocumentItem (j: Json.json) = - { uri = parseDocumentUri (FromJson.asString (FromJson.get "uri" j)) - , languageId = FromJson.asString (FromJson.get "languageId" j) - , version = FromJson.asInt (FromJson.get "version" j) - , text = FromJson.asString (FromJson.get "text" j) - } - - type position = { line: int - , character: int - } - fun parsePosition (j: Json.json) = - { line = FromJson.asInt (FromJson.get "line" j) - , character = FromJson.asInt (FromJson.get "character" j) - } - fun printPosition (p: position): Json.json = Json.Obj [ ("line", Json.Int (#line p)) - , ("character", Json.Int (#character p))] - - type range = { start: position - , end_: position } - fun parseRange (j: Json.json): range = - { start = parsePosition (FromJson.get "start" j) - , end_ = parsePosition (FromJson.get "end" j) - } - fun printRange (r: range): Json.json = Json.Obj [ ("start", printPosition (#start r)) - , ("end", printPosition (#end_ r))] - - fun readRequestFromStdIO (): message = - let - val headers = readAllHeaders () - val lengthO = List.find (fn (k,v) => k = "Content-Length") headers - val request = case lengthO of - NONE => raise Fail "No header with Content-Length found" - | SOME (k, v) => - case Int.fromString v of - NONE => raise Fail ("Couldn't parse content-length from string: " ^ v) - | SOME i => TextIO.inputN (TextIO.stdIn, i) - val parsed = Json.parse request - in - parseMessage parsed - end - - type hoverReq = { textDocument: textDocumentIdentifier , position: position } - type hoverResp = {contents: string} option - fun parseHoverReq (params: Json.json): hoverReq = - { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" params) - , position = parsePosition (FromJson.get "position" params) - } - fun printHoverResponse (resp: hoverResp): Json.json = - case resp of - NONE => Json.Null - | SOME obj => Json.Obj [("contents", Json.String (#contents obj))] - - type didOpenParams = { textDocument: textDocumentItem } - fun parseDidOpenParams (params: Json.json): didOpenParams = - { textDocument = parseTextDocumentItem (FromJson.get "textDocument" params) } - - type contentChange = { range: range option - , rangeLength: int option - , text: string } - type didChangeParams = - { textDocument: versionedTextDocumentIdentifier - , contentChanges: contentChange list - } - fun parseDidChangeParams (params: Json.json): didChangeParams = - { textDocument = parseVersionedTextDocumentIdentifier (FromJson.get "textDocument" params) - , contentChanges = case FromJson.get "contentChanges" params of - Json.Array js => - List.map (fn j => { range = Option.map parseRange (FromJson.getO "range" j) - , rangeLength = Option.map FromJson.asInt (FromJson.getO "rangeLength" j) - , text = FromJson.asString (FromJson.get "text" j) - } - ) js - | j => raise Fail ("Expected JSON array, got: " ^ Json.print j) - } - - type didSaveParams = { textDocument: textDocumentIdentifier } - fun parseDidSaveParams (params: Json.json): didSaveParams = - { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" params) - (* , text = ... *) - } - type didCloseParams = { textDocument: textDocumentIdentifier } - fun parseDidCloseParams (params: Json.json): didCloseParams = - { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" params) - } - type initializeParams = - { rootUri: documentUri option } - fun parseInitializeParams (j: Json.json) = - { rootUri = - Option.map - parseDocumentUri - (FromJson.asOptionalString (FromJson.get "rootUri" j)) - } - type diagnostic = { range: range - (* code?: number | string *) - , severity: int (* 1 = error, 2 = warning, 3 = info, 4 = hint*) - , source: string - , message: string - (* relatedInformation?: DiagnosticRelatedInformation[]; *) - } - fun printDiagnostic (d: diagnostic): Json.json = - Json.Obj [ ("range", printRange (#range d)) - , ("severity", Json.Int (#severity d)) - , ("source", Json.String (#source d)) - , ("message", Json.String (#message d)) - ] - type publishDiagnosticsParams = { uri: documentUri - , diagnostics: diagnostic list - } - fun printPublishDiagnosticsParams (p: publishDiagnosticsParams): Json.json = - Json.Obj [ ("uri", Json.String (printDocumentUri (#uri p))) - , ("diagnostics", Json.Array (List.map printDiagnostic (#diagnostics p)))] - - type completionReq = - { textDocument: textDocumentIdentifier - , position: position - , context: { triggerCharacter: string option - , triggerKind: int (* 1 = Invoked = typing an identifier or manual invocation or API - 2 = TriggerCharacter - 3 = TriggerForIncompleteCompletions*)} option - } - fun parseCompletionReq (j: Json.json): completionReq = - { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" j) - , position = parsePosition (FromJson.get "position" j) - , context = case FromJson.getO "context" j of - NONE => NONE - | SOME ctx => SOME { triggerCharacter = Option.map FromJson.asString (FromJson.getO "triggerCharacter" ctx) - , triggerKind = FromJson.asInt (FromJson.get "triggerKind" ctx) - } - } - - datatype completionItemKind = Text | Method | Function | Constructor | Field | Variable | Class | Interface | Module | Property | Unit | Value | Enum | Keyword | Snippet | Color | File | Reference | Folder | EnumMember | Constant | Struct | Event | Operator | TypeParameter - fun completionItemKindToInt (a: completionItemKind) = - case a of - Text => 1 - | Method => 2 - | Function => 3 - | Constructor => 4 - | Field => 5 - | Variable => 6 - | Class => 7 - | Interface => 8 - | Module => 9 - | Property => 10 - | Unit => 11 - | Value => 12 - | Enum => 13 - | Keyword => 14 - | Snippet => 15 - | Color => 16 - | File => 17 - | Reference => 18 - | Folder => 19 - | EnumMember => 20 - | Constant => 21 - | Struct => 22 - | Event => 23 - | Operator => 24 - | TypeParameter => 25 - - type completionItem = { label: string - , kind: completionItemKind - , detail: string - } - type completionResp = { isIncomplete: bool - , items: completionItem list - } - - fun printCompletionItem (a: completionItem): Json.json = - Json.Obj [ ("label", Json.String (#label a)) - , ("kind", Json.Int (completionItemKindToInt (#kind a))) - , ("detail", Json.String (#detail a)) - ] - fun printCompletionResp (a: completionResp): Json.json = - Json.Obj [ ("isIncomplete", Json.Bool (#isIncomplete a)) - , (("items", Json.Array (List.map printCompletionItem (#items a))))] - - type initializeResponse = { capabilities: - { hoverProvider: bool - , completionProvider: {triggerCharacters: string list} option - , textDocumentSync: - { openClose: bool - , change: int (* 0 = None, 1 = Full, 2 = Incremental *) - , save: { includeText: bool } option - } - }} - fun printInitializeResponse (res: initializeResponse) = - Json.Obj [("capabilities", - let - val capabilities = #capabilities res - in - Json.Obj [ ("hoverProvider", Json.Bool (#hoverProvider capabilities)) - , ("completionProvider", case #completionProvider capabilities of - NONE => Json.Null - | SOME cp => Json.Obj [("triggerCharacters", Json.Array (List.map Json.String (#triggerCharacters cp)))] - ) - , ("textDocumentSync", - let - val textDocumentSync = #textDocumentSync capabilities - in - Json.Obj [ ("openClose", Json.Bool (#openClose textDocumentSync )) - , ("change", Json.Int (#change textDocumentSync)) - , ("save", case #save textDocumentSync of - NONE => Json.Null - | SOME save => Json.Obj [("includeText", Json.Bool (#includeText save) )])] - end - )] - end - )] - - datatype 'a result = - Success of 'a - | Error of (int * string) - - fun mapResult (f: 'a -> 'b) (a: 'a result): 'b result = - case a of - Success contents => Success (f contents) - | Error e => Error e - type toclient = { showMessage: string -> int -> unit - , publishDiagnostics: publishDiagnosticsParams -> unit } - type messageHandlers = - { initialize: initializeParams -> initializeResponse result - , shutdown: unit -> unit result - , textDocument_hover: toclient -> hoverReq -> hoverResp result - , textDocument_completion: completionReq -> completionResp result - } - - fun showMessage str typ = - let - val jsonToPrint = Json.print (Json.Obj [ ("jsonrpc", Json.String "2.0") - , ("method", Json.String "window/showMessage") - , ("params", Json.Obj [ ("type", Json.Int typ) - , ("message", Json.String str)]) - ]) - val toPrint = "Content-Length:" ^ Int.toString (String.size jsonToPrint) ^ "\r\n\r\n" ^ jsonToPrint - in - TextIO.print toPrint - end - fun publishDiagnostics diags = - let - val jsonToPrint = Json.print ((Json.Obj [ ("jsonrpc", Json.String "2.0") - , ("method", Json.String "textDocument/publishDiagnostics") - , ("params", printPublishDiagnosticsParams diags) - ])) - val toPrint = "Content-Length:" ^ Int.toString (String.size jsonToPrint) ^ "\r\n\r\n" ^ jsonToPrint - in - TextIO.print toPrint - end - val toclient: toclient = {showMessage = showMessage, publishDiagnostics = publishDiagnostics} - - fun handleMessage - (requestMessage: {id: Json.json, method: string, params: Json.json}) - (handlers: messageHandlers) - : unit = - let - val result: Json.json result = - case #method requestMessage of - "initialize" => - mapResult - printInitializeResponse - ((#initialize handlers) - (parseInitializeParams (#params requestMessage))) - | "textDocument/hover" => - mapResult - printHoverResponse - ((#textDocument_hover handlers) - toclient - (parseHoverReq (#params requestMessage))) - | "textDocument/completion" => - mapResult - printCompletionResp - ((#textDocument_completion handlers) - (parseCompletionReq (#params requestMessage))) - | "shutdown" => - mapResult - (fn () => Json.Null) - ((#shutdown handlers) ()) - | "exit" => - OS.Process.exit OS.Process.success - | method => (debug ("Method not supported: " ^ method); - Error (~32601, "Method not supported: " ^ method)) - (* val () = (TextIO.output (TextIO.stdErr, "Got result: " ^ (case result of Success _ => "success\n" *) - (* | Error _ => "error\n")); TextIO.flushOut TextIO.stdErr) *) - in - case result of - Success j => - let - val jsonToPrint = - Json.print (Json.Obj [ ("id", #id requestMessage) - , ("jsonrpc", Json.String "2.0") - , ("result", j) - ]) - val toPrint = "Content-Length:" ^ Int.toString (String.size jsonToPrint) ^ "\r\n\r\n" ^ jsonToPrint - in - TextIO.print toPrint - end - | Error (i, err) => - let - val jsonToPrint = - Json.print (Json.Obj [ ("id", #id requestMessage) - , ("jsonrpc", Json.String "2.0") - , ("error", Json.Obj [ ("code", Json.Int i) - , ("message", Json.String err) - ]) - ]) - val toPrint = "Content-Length:" ^ Int.toString (String.size jsonToPrint) ^ "\r\n\r\n" ^ jsonToPrint - in - TextIO.print toPrint - end - end - - type notificationHandlers = - { initialized: unit -> unit - , textDocument_didOpen: toclient -> didOpenParams -> unit - , textDocument_didChange: toclient -> didChangeParams -> unit - , textDocument_didSave: toclient -> didSaveParams -> unit - , textDocument_didClose: toclient -> didCloseParams -> unit - } - fun handleNotification - (notification: {method: string, params: Json.json}) - (handlers: notificationHandlers) - = - case #method notification of - "initialized" => (#initialized handlers) () - | "textDocument/didOpen" => (#textDocument_didOpen handlers) toclient (parseDidOpenParams (#params notification)) - | "textDocument/didChange" => (#textDocument_didChange handlers) toclient (parseDidChangeParams (#params notification)) - | "textDocument/didSave" => (#textDocument_didSave handlers) toclient (parseDidSaveParams (#params notification)) - | "textDocument/didClose" => (#textDocument_didClose handlers) toclient (parseDidCloseParams (#params notification)) - | m => debug ("Notification method not supported: " ^ m) - -end structure Lsp :> LSP = struct - -datatype lspError = InternalError of string -exception LspError of lspError -fun handleLspErrorInNotification (e: lspError) : unit = - let - fun print (message: string) = - let - val jsonStr = Json.print (Json.Obj [ ("jsonrpc", Json.String "2.0") - , ("method", Json.String "window/showMessage") - , ("params", Json.Obj [ ("type", Json.Int 1 (* Error*)) - , ("message", Json.String message)]) - ]) - in - TextIO.print ("Content-Length:" ^ Int.toString (String.size jsonStr) ^ "\r\n\r\n" ^ jsonStr) - end - in - case e of - InternalError str => print str - end -fun handleLspErrorInRequest (id: Json.json) (e: lspError): unit = - let - fun print (code: int) (message: string) = - let - val jsonStr = Json.print (Json.Obj [ ("jsonrpc", Json.String "2.0") - , ("id", id) - , ("error", Json.Obj [ ("code", Json.Int code (* Error*)) - , ("message", Json.String message)]) - ]) - in - TextIO.print ("Content-Length:" ^ Int.toString (String.size jsonStr) ^ "\r\n\r\n" ^ jsonStr) - end - in - case e of - InternalError str => print (~32603) str - end +val debug = LspSpec.debug structure SK = struct type ord_key = string @@ -614,7 +103,7 @@ fun elabFile (state: state) (fileName: string): ({ decls: Elab.decl list, envBef val () = Elaborate.incremental := true (* Parsing .urp *) val job = case C.run (C.transform C.parseUrp "parseUrp") (#urpPath state) of - NONE => raise LspError (InternalError ("Couldn't parse .urp file at " ^ (#urpPath state))) + NONE => raise LspSpec.LspError (LspSpec.InternalError ("Couldn't parse .urp file at " ^ (#urpPath state))) | SOME a => a val moduleSearchRes = List.foldl @@ -629,7 +118,7 @@ fun elabFile (state: state) (fileName: string): ({ decls: Elab.decl list, envBef val modulesBeforeThisFile = #1 moduleSearchRes val () = if #2 moduleSearchRes then () - else raise LspError (InternalError ("Couldn't find file " ^ fileName ^ " referenced in .urp file at " ^ (#urpPath state))) + else raise LspSpec.LspError (LspSpec.InternalError ("Couldn't find file " ^ fileName ^ " referenced in .urp file at " ^ (#urpPath state))) (* Parsing .urs files of previous modules *) val parsedUrss = List.map (fn entry => let @@ -639,9 +128,9 @@ fun elabFile (state: state) (fileName: string): ({ decls: Elab.decl list, envBef , parsed = if OS.FileSys.access (fileName, []) then case C.run (C.transform C.parseUrs "parseUrs") fileName of - NONE => raise LspError (InternalError ("Failed to parse .urs file at " ^ fileName)) + NONE => raise LspSpec.LspError (LspSpec.InternalError ("Failed to parse .urs file at " ^ fileName)) | SOME a => a - else raise LspError (InternalError ("Couldn't find an .urs file for " ^ fileName)) + else raise LspSpec.LspError (LspSpec.InternalError ("Couldn't find an .urs file for " ^ fileName)) } end) modulesBeforeThisFile @@ -655,15 +144,15 @@ fun elabFile (state: state) (fileName: string): ({ decls: Elab.decl list, envBef val parsedBasisUrs = case C.run (C.transform C.parseUrs "parseUrs") basisF of - NONE => raise LspError (InternalError ("Failed to parse basis.urs file at " ^ basisF)) + NONE => raise LspSpec.LspError (LspSpec.InternalError ("Failed to parse basis.urs file at " ^ basisF)) | SOME a => a val parsedTopUrs = case C.run (C.transform C.parseUrs "parseUrs") topF of - NONE => raise LspError (InternalError ("Failed to parse top.urs file at " ^ topF)) + NONE => raise LspSpec.LspError (LspSpec.InternalError ("Failed to parse top.urs file at " ^ topF)) | SOME a => a val parsedTopUr = case C.run (C.transform C.parseUr "parseUr") topF' of - NONE => raise LspError (InternalError ("Failed to parse top.ur file at " ^ topF')) + NONE => raise LspSpec.LspError (LspSpec.InternalError ("Failed to parse top.ur file at " ^ topF')) | SOME a => a (* Parsing .ur and .urs of current file *) @@ -1031,10 +520,10 @@ fun handleDocumentDidClose (state: state) (toclient: LspSpec.toclient) (p: LspSp fun serverLoop () = let + val state = !stateRef val requestMessage = LspSpec.readRequestFromStdIO () handle ex => (debug (General.exnMessage ex) ; raise ex) - val state = !stateRef in case state of NONE => @@ -1065,7 +554,7 @@ fun serverLoop () = | SOME state => (case requestMessage of LspSpec.Notification n => - ((LspSpec.handleNotification + (LspSpec.handleNotification n { initialized = fn () => () , textDocument_didOpen = fn toclient => fn p => handleDocumentSavedOrOpened state toclient (#uri (#textDocument p)) (SOME (#text (#textDocument p))) @@ -1073,19 +562,15 @@ fun serverLoop () = , textDocument_didSave = fn toclient => fn p => handleDocumentSavedOrOpened state toclient (#uri (#textDocument p)) NONE , textDocument_didClose = fn toclient => fn p => handleDocumentDidClose state toclient p }) - handle LspError e => handleLspErrorInNotification e - | ex => handleLspErrorInNotification (InternalError (General.exnMessage ex))) | LspSpec.RequestMessage m => (* TODO should error handling here be inside handleMessage? *) - ((LspSpec.handleMessage + (LspSpec.handleMessage m { initialize = fn _ => LspSpec.Error (~32600, "Server already initialized") , shutdown = fn () => LspSpec.Success () , textDocument_hover = fn toclient => handleHover state , textDocument_completion = handleCompletion state }) - handle LspError e => handleLspErrorInRequest (#id m) e - | ex => handleLspErrorInRequest (#id m) (InternalError (General.exnMessage ex))) ) end diff --git a/src/lspspec.sml b/src/lspspec.sml new file mode 100644 index 00000000..7993038e --- /dev/null +++ b/src/lspspec.sml @@ -0,0 +1,447 @@ +structure LspSpec = struct + + datatype lspError = InternalError of string + exception LspError of lspError + + fun debug (str: string): unit = + (TextIO.output (TextIO.stdErr, str ^ "\n\n"); TextIO.flushOut TextIO.stdErr) + + fun trim (s: substring): substring = + Substring.dropr + (fn c => c = #" " orelse c = #"\n" orelse c = #"\r") + (Substring.dropl (fn c => c = #" " orelse c = #"\n" orelse c = #"\r") s) + + fun readHeader (): (string * string) option = + let + val line = TextIO.inputLine TextIO.stdIn + in + case line of + NONE => OS.Process.exit OS.Process.success + | SOME str => + if Substring.isEmpty (trim (Substring.full str)) + then NONE + else + let + val (key, value) = Substring.splitl (fn c => c <> #":") (Substring.full str) + in + if Substring.isEmpty (trim value) + then raise Fail ("Failed to parse LSP header: Line is not empty but is also not a valid header: " ^ str) + else SOME ( Substring.string (trim key) + , Substring.string (trim (Substring.dropl (fn c => c = #":") (trim value)))) + end + end + + fun readAllHeaders (): (string * string) list = + let + fun doReadAllHeaders (l: (string * string) list): (string * string) list = + case readHeader () of + NONE => l + | SOME tup => tup :: doReadAllHeaders l + + in + doReadAllHeaders [] + end + datatype message = + RequestMessage of { id: Json.json, method: string, params: Json.json} + | Notification of { method: string, params: Json.json} + fun parseMessage (j: Json.json): message = + let + val id = SOME (FromJson.get "id" j) + handle ex => NONE + val method = FromJson.asString (FromJson.get "method" j) + val params = FromJson.get "params" j + in + case id of + NONE => Notification {method = method, params = params} + | SOME id => RequestMessage {id = id, method = method, params = params} + end + + type documentUri = + { scheme: string + , authority: string + , path: string + , query: string + , fragment: string + } + fun parseDocumentUri (str: string): documentUri = + let + val str = Substring.full str + val (scheme, rest) = Substring.splitl (fn c => c <> #":") str + val (authority, rest) = Substring.splitl (fn c => c <> #"/") (Substring.triml 3 rest (* :// *)) + val (path, rest) = Substring.splitl (fn c => c <> #"?" orelse c <> #"#") rest + val (query, rest) = if Substring.first rest = SOME #"?" + then Substring.splitl (fn c => c <> #"#") (Substring.triml 1 rest (* ? *)) + else (Substring.full "", rest) + val fragment = if Substring.first rest = SOME #"#" + then (Substring.triml 1 rest (* # *)) + else Substring.full "" + + in + { scheme = Substring.string scheme + , authority = Substring.string authority + , path = Substring.string path + , query = Substring.string query + , fragment = Substring.string fragment + } + end + fun printDocumentUri (d: documentUri) = + (#scheme d) ^ "://" ^ + (#authority d) ^ + (#path d) ^ + (if #query d <> "" then "?" ^ #query d else "") ^ + (if #fragment d <> "" then "#" ^ #fragment d else "") + + type textDocumentIdentifier = { uri: documentUri} + fun parseTextDocumentIdentifier (j: Json.json): textDocumentIdentifier = + { uri = parseDocumentUri (FromJson.asString (FromJson.get "uri" j))} + + type versionedTextDocumentIdentifier = + { uri: documentUri + , version: int option + } + fun parseVersionedTextDocumentIdentifier (j: Json.json): versionedTextDocumentIdentifier = + { uri = parseDocumentUri (FromJson.asString (FromJson.get "uri" j)) + , version = FromJson.asOptionalInt (FromJson.get "version" j) + } + + type textDocumentItem = { + uri: documentUri, + languageId: string, + version: int, (* The version number of this document (it will increase after each change, including undo/redo). *) + text: string + } + fun parseTextDocumentItem (j: Json.json) = + { uri = parseDocumentUri (FromJson.asString (FromJson.get "uri" j)) + , languageId = FromJson.asString (FromJson.get "languageId" j) + , version = FromJson.asInt (FromJson.get "version" j) + , text = FromJson.asString (FromJson.get "text" j) + } + + type position = { line: int + , character: int + } + fun parsePosition (j: Json.json) = + { line = FromJson.asInt (FromJson.get "line" j) + , character = FromJson.asInt (FromJson.get "character" j) + } + fun printPosition (p: position): Json.json = Json.Obj [ ("line", Json.Int (#line p)) + , ("character", Json.Int (#character p))] + + type range = { start: position + , end_: position } + fun parseRange (j: Json.json): range = + { start = parsePosition (FromJson.get "start" j) + , end_ = parsePosition (FromJson.get "end" j) + } + fun printRange (r: range): Json.json = Json.Obj [ ("start", printPosition (#start r)) + , ("end", printPosition (#end_ r))] + + fun readRequestFromStdIO (): message = + let + val headers = readAllHeaders () + val lengthO = List.find (fn (k,v) => k = "Content-Length") headers + val request = case lengthO of + NONE => raise Fail "No header with Content-Length found" + | SOME (k, v) => + case Int.fromString v of + NONE => raise Fail ("Couldn't parse content-length from string: " ^ v) + | SOME i => TextIO.inputN (TextIO.stdIn, i) + val parsed = Json.parse request + in + parseMessage parsed + end + + type hoverReq = { textDocument: textDocumentIdentifier , position: position } + type hoverResp = {contents: string} option + fun parseHoverReq (params: Json.json): hoverReq = + { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" params) + , position = parsePosition (FromJson.get "position" params) + } + fun printHoverResponse (resp: hoverResp): Json.json = + case resp of + NONE => Json.Null + | SOME obj => Json.Obj [("contents", Json.String (#contents obj))] + + type didOpenParams = { textDocument: textDocumentItem } + fun parseDidOpenParams (params: Json.json): didOpenParams = + { textDocument = parseTextDocumentItem (FromJson.get "textDocument" params) } + + type contentChange = { range: range option + , rangeLength: int option + , text: string } + type didChangeParams = + { textDocument: versionedTextDocumentIdentifier + , contentChanges: contentChange list + } + fun parseDidChangeParams (params: Json.json): didChangeParams = + { textDocument = parseVersionedTextDocumentIdentifier (FromJson.get "textDocument" params) + , contentChanges = case FromJson.get "contentChanges" params of + Json.Array js => + List.map (fn j => { range = Option.map parseRange (FromJson.getO "range" j) + , rangeLength = Option.map FromJson.asInt (FromJson.getO "rangeLength" j) + , text = FromJson.asString (FromJson.get "text" j) + } + ) js + | j => raise Fail ("Expected JSON array, got: " ^ Json.print j) + } + + type didSaveParams = { textDocument: textDocumentIdentifier } + fun parseDidSaveParams (params: Json.json): didSaveParams = + { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" params) + (* , text = ... *) + } + type didCloseParams = { textDocument: textDocumentIdentifier } + fun parseDidCloseParams (params: Json.json): didCloseParams = + { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" params) + } + type initializeParams = + { rootUri: documentUri option } + fun parseInitializeParams (j: Json.json) = + { rootUri = + Option.map + parseDocumentUri + (FromJson.asOptionalString (FromJson.get "rootUri" j)) + } + type diagnostic = { range: range + (* code?: number | string *) + , severity: int (* 1 = error, 2 = warning, 3 = info, 4 = hint*) + , source: string + , message: string + (* relatedInformation?: DiagnosticRelatedInformation[]; *) + } + fun printDiagnostic (d: diagnostic): Json.json = + Json.Obj [ ("range", printRange (#range d)) + , ("severity", Json.Int (#severity d)) + , ("source", Json.String (#source d)) + , ("message", Json.String (#message d)) + ] + type publishDiagnosticsParams = { uri: documentUri + , diagnostics: diagnostic list + } + fun printPublishDiagnosticsParams (p: publishDiagnosticsParams): Json.json = + Json.Obj [ ("uri", Json.String (printDocumentUri (#uri p))) + , ("diagnostics", Json.Array (List.map printDiagnostic (#diagnostics p)))] + + type completionReq = + { textDocument: textDocumentIdentifier + , position: position + , context: { triggerCharacter: string option + , triggerKind: int (* 1 = Invoked = typing an identifier or manual invocation or API + 2 = TriggerCharacter + 3 = TriggerForIncompleteCompletions*)} option + } + fun parseCompletionReq (j: Json.json): completionReq = + { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" j) + , position = parsePosition (FromJson.get "position" j) + , context = case FromJson.getO "context" j of + NONE => NONE + | SOME ctx => SOME { triggerCharacter = Option.map FromJson.asString (FromJson.getO "triggerCharacter" ctx) + , triggerKind = FromJson.asInt (FromJson.get "triggerKind" ctx) + } + } + + datatype completionItemKind = Text | Method | Function | Constructor | Field | Variable | Class | Interface | Module | Property | Unit | Value | Enum | Keyword | Snippet | Color | File | Reference | Folder | EnumMember | Constant | Struct | Event | Operator | TypeParameter + fun completionItemKindToInt (a: completionItemKind) = + case a of + Text => 1 + | Method => 2 + | Function => 3 + | Constructor => 4 + | Field => 5 + | Variable => 6 + | Class => 7 + | Interface => 8 + | Module => 9 + | Property => 10 + | Unit => 11 + | Value => 12 + | Enum => 13 + | Keyword => 14 + | Snippet => 15 + | Color => 16 + | File => 17 + | Reference => 18 + | Folder => 19 + | EnumMember => 20 + | Constant => 21 + | Struct => 22 + | Event => 23 + | Operator => 24 + | TypeParameter => 25 + + type completionItem = { label: string + , kind: completionItemKind + , detail: string + } + type completionResp = { isIncomplete: bool + , items: completionItem list + } + + fun printCompletionItem (a: completionItem): Json.json = + Json.Obj [ ("label", Json.String (#label a)) + , ("kind", Json.Int (completionItemKindToInt (#kind a))) + , ("detail", Json.String (#detail a)) + ] + fun printCompletionResp (a: completionResp): Json.json = + Json.Obj [ ("isIncomplete", Json.Bool (#isIncomplete a)) + , (("items", Json.Array (List.map printCompletionItem (#items a))))] + + type initializeResponse = { capabilities: + { hoverProvider: bool + , completionProvider: {triggerCharacters: string list} option + , textDocumentSync: + { openClose: bool + , change: int (* 0 = None, 1 = Full, 2 = Incremental *) + , save: { includeText: bool } option + } + }} + fun printInitializeResponse (res: initializeResponse) = + Json.Obj [("capabilities", + let + val capabilities = #capabilities res + in + Json.Obj [ ("hoverProvider", Json.Bool (#hoverProvider capabilities)) + , ("completionProvider", case #completionProvider capabilities of + NONE => Json.Null + | SOME cp => Json.Obj [("triggerCharacters", Json.Array (List.map Json.String (#triggerCharacters cp)))] + ) + , ("textDocumentSync", + let + val textDocumentSync = #textDocumentSync capabilities + in + Json.Obj [ ("openClose", Json.Bool (#openClose textDocumentSync )) + , ("change", Json.Int (#change textDocumentSync)) + , ("save", case #save textDocumentSync of + NONE => Json.Null + | SOME save => Json.Obj [("includeText", Json.Bool (#includeText save) )])] + end + )] + end + )] + + datatype 'a result = + Success of 'a + | Error of (int * string) + + fun mapResult (f: 'a -> 'b) (a: 'a result): 'b result = + case a of + Success contents => Success (f contents) + | Error e => Error e + type toclient = { showMessage: string -> int -> unit + , publishDiagnostics: publishDiagnosticsParams -> unit } + type messageHandlers = + { initialize: initializeParams -> initializeResponse result + , shutdown: unit -> unit result + , textDocument_hover: toclient -> hoverReq -> hoverResp result + , textDocument_completion: completionReq -> completionResp result + } + + fun showMessage str typ = + let + val jsonToPrint = Json.print (Json.Obj [ ("jsonrpc", Json.String "2.0") + , ("method", Json.String "window/showMessage") + , ("params", Json.Obj [ ("type", Json.Int typ) + , ("message", Json.String str)]) + ]) + val toPrint = "Content-Length:" ^ Int.toString (String.size jsonToPrint) ^ "\r\n\r\n" ^ jsonToPrint + in + TextIO.print toPrint + end + fun publishDiagnostics diags = + let + val jsonToPrint = Json.print ((Json.Obj [ ("jsonrpc", Json.String "2.0") + , ("method", Json.String "textDocument/publishDiagnostics") + , ("params", printPublishDiagnosticsParams diags) + ])) + val toPrint = "Content-Length:" ^ Int.toString (String.size jsonToPrint) ^ "\r\n\r\n" ^ jsonToPrint + in + TextIO.print toPrint + end + val toclient: toclient = {showMessage = showMessage, publishDiagnostics = publishDiagnostics} + + fun handleMessage + (requestMessage: {id: Json.json, method: string, params: Json.json}) + (handlers: messageHandlers) + : unit = + let + val result: Json.json result = + ((case #method requestMessage of + "initialize" => + mapResult + printInitializeResponse + ((#initialize handlers) + (parseInitializeParams (#params requestMessage))) + | "textDocument/hover" => + mapResult + printHoverResponse + ((#textDocument_hover handlers) + toclient + (parseHoverReq (#params requestMessage))) + | "textDocument/completion" => + mapResult + printCompletionResp + ((#textDocument_completion handlers) + (parseCompletionReq (#params requestMessage))) + | "shutdown" => + mapResult + (fn () => Json.Null) + ((#shutdown handlers) ()) + | "exit" => + OS.Process.exit OS.Process.success + | method => (debug ("Method not supported: " ^ method); + Error (~32601, "Method not supported: " ^ method))) + handle LspError (InternalError str) => Error (~32603, str) + | ex => Error (~32603, (General.exnMessage ex)) + ) + (* val () = (TextIO.output (TextIO.stdErr, "Got result: " ^ (case result of Success _ => "success\n" *) + (* | Error _ => "error\n")); TextIO.flushOut TextIO.stdErr) *) + in + case result of + Success j => + let + val jsonToPrint = + Json.print (Json.Obj [ ("id", #id requestMessage) + , ("jsonrpc", Json.String "2.0") + , ("result", j) + ]) + val toPrint = "Content-Length:" ^ Int.toString (String.size jsonToPrint) ^ "\r\n\r\n" ^ jsonToPrint + in + TextIO.print toPrint + end + | Error (i, err) => + let + val jsonToPrint = + Json.print (Json.Obj [ ("id", #id requestMessage) + , ("jsonrpc", Json.String "2.0") + , ("error", Json.Obj [ ("code", Json.Int i) + , ("message", Json.String err) + ]) + ]) + val toPrint = "Content-Length:" ^ Int.toString (String.size jsonToPrint) ^ "\r\n\r\n" ^ jsonToPrint + in + TextIO.print toPrint + end + end + + type notificationHandlers = + { initialized: unit -> unit + , textDocument_didOpen: toclient -> didOpenParams -> unit + , textDocument_didChange: toclient -> didChangeParams -> unit + , textDocument_didSave: toclient -> didSaveParams -> unit + , textDocument_didClose: toclient -> didCloseParams -> unit + } + fun handleNotification + (notification: {method: string, params: Json.json}) + (handlers: notificationHandlers) + = + (case #method notification of + "initialized" => (#initialized handlers) () + | "textDocument/didOpen" => (#textDocument_didOpen handlers) toclient (parseDidOpenParams (#params notification)) + | "textDocument/didChange" => (#textDocument_didChange handlers) toclient (parseDidChangeParams (#params notification)) + | "textDocument/didSave" => (#textDocument_didSave handlers) toclient (parseDidSaveParams (#params notification)) + | "textDocument/didClose" => (#textDocument_didClose handlers) toclient (parseDidCloseParams (#params notification)) + | m => debug ("Notification method not supported: " ^ m)) + handle LspError (InternalError str) => showMessage str 1 + | ex => showMessage (General.exnMessage ex) 1 + +end diff --git a/src/sources b/src/sources index c407ea2a..74171365 100644 --- a/src/sources +++ b/src/sources @@ -280,6 +280,11 @@ $(SRC)/getinfo.sml $(SRC)/json.sig $(SRC)/json.sml +$(SRC)/fromjson.sig +$(SRC)/fromjson.sml + +$(SRC)/lspspec.sml + $(SRC)/lsp.sig $(SRC)/lsp.sml -- cgit v1.2.3 From e74d203806efea612ef2ab33da1e561c077d6c16 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Fri, 13 Dec 2019 14:44:20 +0100 Subject: Added initializationOption to specify project if multiple urp files --- src/lsp.sml | 11 ++++++++--- src/lspspec.sml | 4 +++- 2 files changed, 11 insertions(+), 4 deletions(-) (limited to 'src/lsp.sml') diff --git a/src/lsp.sml b/src/lsp.sml index d902fed4..34137a4f 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -47,12 +47,17 @@ fun initState (initParams: LspSpec.initializeParams): state = val rootPath = case #rootUri initParams of NONE => raise Fail "No rootdir found" | SOME a => #path a + val optsUrpFile = + (SOME (FromJson.asString (FromJson.get "urpfile" (FromJson.get "project" (FromJson.get "urweb" (#initializationOptions initParams)))))) + handle ex => NONE 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 :: [] => OS.Path.base (OS.Path.file one) - | many => raise Fail ("Found multiple .urp files in path " ^ rootPath) + | many => case List.find (fn m => SOME (OS.Path.base (OS.Path.file m)) = optsUrpFile) many of + NONE => raise Fail ("Found multiple .urp files in path " ^ rootPath) + | SOME f => OS.Path.base (OS.Path.file f) , fileStates = SM.empty } end @@ -531,8 +536,8 @@ fun serverLoop () = LspSpec.RequestMessage m => LspSpec.handleMessage m - { initialize = fn _ => - (let val st = initState (LspSpec.parseInitializeParams (#params m)) + { initialize = fn p => + (let val st = initState p in stateRef := SOME st; LspSpec.Success diff --git a/src/lspspec.sml b/src/lspspec.sml index 7993038e..fe1711f0 100644 --- a/src/lspspec.sml +++ b/src/lspspec.sml @@ -195,12 +195,14 @@ structure LspSpec = struct { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" params) } type initializeParams = - { rootUri: documentUri option } + { rootUri: documentUri option + , initializationOptions: Json.json } fun parseInitializeParams (j: Json.json) = { rootUri = Option.map parseDocumentUri (FromJson.asOptionalString (FromJson.get "rootUri" j)) + , initializationOptions = FromJson.get "initializationOptions" j } type diagnostic = { range: range (* code?: number | string *) -- cgit v1.2.3 From 1fb21cbcb469891265a8be66d992b38ba5a6e05e Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Fri, 13 Dec 2019 20:03:01 +0100 Subject: Always add text to fileState even if elabState throws --- src/lsp.sml | 36 ++++++++++++++++++++++++------------ 1 file changed, 24 insertions(+), 12 deletions(-) (limited to 'src/lsp.sml') diff --git a/src/lsp.sml b/src/lsp.sml index 34137a4f..4e5e0637 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -204,12 +204,14 @@ fun elabFile (state: state) (fileName: string): ({ decls: Elab.decl list, envBef end end +(* TODO Bad API: text0 = NONE is Save, text0 = SOME is open *) +(* TODO whole function isn't great, could use a refactor *) fun handleDocumentSavedOrOpened (state: state) (toclient: LspSpec.toclient) (documentUri: LspSpec.documentUri) (textO: string option) = let val fileName = #path documentUri - val res = elabFile state fileName + val previousState = SM.find (#fileStates state, fileName) val text = case textO of - NONE => (case SM.find (#fileStates state, fileName) of + NONE => (case previousState of NONE => ((#showMessage toclient) ("No previous state for file " ^ fileName) 2; NONE) | SOME previousState => SOME (#text previousState)) | SOME text => SOME text @@ -217,16 +219,26 @@ fun handleDocumentSavedOrOpened (state: state) (toclient: LspSpec.toclient) (doc 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}) + let + (* Insert text before elabFile since that can fail *) + val () = insertFileState state fileName { text = text + , envBeforeThisModule = case previousState of + NONE => ElabEnv.empty + | SOME p => #envBeforeThisModule p + , decls = case previousState of + NONE => [] + | SOME p => #decls p + } + val res = elabFile state fileName + in + (case #1 res of + NONE => () + | SOME fs => + (insertFileState state fileName { text = text + , envBeforeThisModule = #envBeforeThisModule fs + , decls = #decls fs }); + #publishDiagnostics toclient { uri = documentUri , diagnostics = #2 res}) + end end fun scanDir (f: string -> bool) (path: string) = -- cgit v1.2.3 From e21042fe736d9bffe7b0b83420530a5b2c0930e7 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Fri, 13 Dec 2019 21:17:03 +0100 Subject: Fixed ppToString --- src/lsp.sml | 26 ++++++++++++++------------ 1 file changed, 14 insertions(+), 12 deletions(-) (limited to 'src/lsp.sml') diff --git a/src/lsp.sml b/src/lsp.sml index 4e5e0637..a39c8237 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -257,14 +257,16 @@ fun scanDir (f: string -> bool) (path: string) = fun readFile (fileName: string): string = let - val str = TextIO.openIn fileName + val stream = TextIO.openIn fileName fun doReadFile acc = - case TextIO.inputLine str of + case TextIO.inputLine stream of NONE => acc - | SOME str => (str ^ "\n" ^ acc) + | SOME str => (if acc = "" + then doReadFile str + else doReadFile (acc ^ str)) val res = doReadFile "" in - (TextIO.closeIn str; res) + (TextIO.closeIn stream; res) end @@ -299,7 +301,7 @@ fun handleHover (state: state) (p: LspSpec.hoverReq): LspSpec.hoverResp LspSpec. case #smallestgoodpart result of NONE => LspSpec.Success NONE | SOME {desc = desc, ...} => - LspSpec.Success (SOME {contents = ppToString desc 70}) + LspSpec.Success (SOME {contents = ppToString desc 50}) end end @@ -311,7 +313,7 @@ fun getCompletionsFromFields (env: ElabEnv.env) (prefix: string) (searchStr: str if String.isPrefix searchStr fieldName then SOME { label = prefix ^ fieldName , kind = LspSpec.Field - , detail = ppToString (ElabPrint.p_con env c2) 150 + , detail = ppToString (ElabPrint.p_con env c2) 200 } else NONE | _ => NONE @@ -327,14 +329,14 @@ fun getCompletionsFromSignatureItems (env: ElabEnv.env) (prefix: string) (search if String.isPrefix searchStr name then [{ label = prefix ^ name , kind = LspSpec.Value - , detail = ppToString (ElabPrint.p_con env con) 150 + , detail = ppToString (ElabPrint.p_con env con) 200 }] else [] | (Elab.SgiCon (name, _, _, con), _) => if String.isPrefix searchStr name then [{ label = prefix ^ name , kind = LspSpec.Value - , detail = ppToString (ElabPrint.p_con env con) 150 + , detail = ppToString (ElabPrint.p_con env con) 200 }] else [] | (Elab.SgiDatatype cs, _) => @@ -353,7 +355,7 @@ fun getCompletionsFromSignatureItems (env: ElabEnv.env) (prefix: string) (search , kind = LspSpec.Function , detail = case conO of NONE => dtName ^ typeVarsString - | SOME con => ppToString (ElabPrint.p_con env con) 150 ^ " -> " ^ dtName ^ typeVarsString + | SOME con => ppToString (ElabPrint.p_con env con) 200 ^ " -> " ^ dtName ^ typeVarsString } else NONE) constrs end) @@ -372,7 +374,7 @@ fun getCompletionsFromSignatureItems (env: ElabEnv.env) (prefix: string) (search if String.isPrefix searchStr name then [{ label = prefix ^ name , kind = LspSpec.Class - , detail = ppToString (ElabPrint.p_con env con) 150 + , detail = ppToString (ElabPrint.p_con env con) 200 }] else [] | _ => [] @@ -395,7 +397,7 @@ fun findMatchingStringInEnv (env: ElabEnv.env) (str: string): LspSpec.completion val expressionCompletions = List.map (fn (name,con) => { label = name , kind = LspSpec.Value - , detail = ppToString (ElabPrint.p_con env con) 150 + , detail = ppToString (ElabPrint.p_con env con) 200 }) matchingEs val matchingStrs = ElabEnv.matchStrByPrefix env str val structureCompletions = List.map (fn (name,(_,sgn)) => @@ -407,7 +409,7 @@ fun findMatchingStringInEnv (env: ElabEnv.env) (str: string): LspSpec.completion val conCompletions = List.map (fn (name,kind) => { label = name , kind = LspSpec.Constructor (* TODO probably wrong... *) - , detail = ppToString (ElabPrint.p_kind env kind) 150 + , detail = ppToString (ElabPrint.p_kind env kind) 200 }) matchingCons in expressionCompletions @ structureCompletions @ conCompletions -- cgit v1.2.3 From aee7b6df39b763518dead8f160725c06fb8c7d66 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Fri, 13 Dec 2019 21:17:11 +0100 Subject: Parse also FFi .urs files --- src/lsp.sml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/lsp.sml') diff --git a/src/lsp.sml b/src/lsp.sml index a39c8237..4259c9ec 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -119,7 +119,7 @@ fun elabFile (state: state) (fileName: string): ({ decls: Elab.decl list, envBef then (List.rev (#1 acc), true) else (entry :: #1 acc, false)) ([] (* modules before *), false (* module found *)) - (#sources job) + (#ffi job @ #sources job) val modulesBeforeThisFile = #1 moduleSearchRes val () = if #2 moduleSearchRes then () -- cgit v1.2.3 From 91d154f3fa8634698faea010c9d965009a76fbcb Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Sat, 14 Dec 2019 12:47:27 +0100 Subject: Refactored state into its own module --- src/lsp.sml | 210 +++++++++++++++++++++++++++++--------------------------- src/lspspec.sml | 23 ++++--- 2 files changed, 121 insertions(+), 112 deletions(-) (limited to 'src/lsp.sml') diff --git a/src/lsp.sml b/src/lsp.sml index 4259c9ec..23b54a28 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -18,14 +18,68 @@ type state = { urpPath : string , fileStates : fileState SM.map } + +(* Wrapping this in structure as an attempt to not get concurrency bugs *) +structure State : + sig + val init: state -> unit + val insertText: string -> string -> unit + val insertElabRes: string -> ElabEnv.env -> Elab.decl list -> unit + val removeFile: string -> unit + val withState: (state -> 'a) -> 'a + end = struct val stateRef = ref (NONE: state option) +fun init (s: state) = + stateRef := SOME s +fun withState (f: state -> 'a): 'a = + case !stateRef of + NONE => raise LspSpec.LspError LspSpec.ServerNotInitialized + | SOME s => f s + +fun insertText (fileName: string) (text: string) = + withState (fn oldS => + stateRef := SOME { urpPath = #urpPath oldS + , fileStates = + case SM.find (#fileStates oldS, fileName) of + NONE => SM.insert ( #fileStates oldS + , fileName + , { text = text + , decls = [] + , envBeforeThisModule = ElabEnv.empty }) + | SOME oldfs => + SM.insert ( #fileStates oldS + , fileName + , { text = text + , decls = #decls oldfs + , envBeforeThisModule = #envBeforeThisModule oldfs }) + } + ) + +fun insertElabRes (fileName: string) (env: ElabEnv.env) decls = + withState (fn oldS => + stateRef := SOME { urpPath = #urpPath oldS + , fileStates = + case SM.find (#fileStates oldS, fileName) of + NONE => raise Fail ("No text found for file " ^ fileName) + | SOME oldfs => + SM.insert ( #fileStates oldS + , fileName + , { text = #text oldfs + , decls = decls + , envBeforeThisModule = env }) + } + ) + +fun removeFile (fileName: string) = + withState (fn oldS => + stateRef := SOME { urpPath = #urpPath oldS + , fileStates = #1 (SM.remove (#fileStates oldS, fileName)) + } + ) + +end + -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 @@ -204,41 +258,16 @@ fun elabFile (state: state) (fileName: string): ({ decls: Elab.decl list, envBef end end -(* TODO Bad API: text0 = NONE is Save, text0 = SOME is open *) -(* TODO whole function isn't great, could use a refactor *) -fun handleDocumentSavedOrOpened (state: state) (toclient: LspSpec.toclient) (documentUri: LspSpec.documentUri) (textO: string option) = +fun elabFileAndSendDiags (state: state) (toclient: LspSpec.toclient) (documentUri: LspSpec.documentUri): unit = let val fileName = #path documentUri - val previousState = SM.find (#fileStates state, fileName) - val text = case textO of - NONE => (case previousState of - NONE => ((#showMessage toclient) ("No previous state for file " ^ fileName) 2; NONE) - | SOME previousState => SOME (#text previousState)) - | SOME text => SOME text + val res = elabFile state fileName in - case text of - NONE => () - | SOME text => - let - (* Insert text before elabFile since that can fail *) - val () = insertFileState state fileName { text = text - , envBeforeThisModule = case previousState of - NONE => ElabEnv.empty - | SOME p => #envBeforeThisModule p - , decls = case previousState of - NONE => [] - | SOME p => #decls p - } - val res = elabFile state fileName - in - (case #1 res of - NONE => () - | SOME fs => - (insertFileState state fileName { text = text - , envBeforeThisModule = #envBeforeThisModule fs - , decls = #decls fs }); - #publishDiagnostics toclient { uri = documentUri , diagnostics = #2 res}) - end + (case #1 res of + NONE => () + | SOME fs => + (State.insertElabRes fileName (#envBeforeThisModule fs) (#decls fs)); + #publishDiagnostics toclient { uri = documentUri , diagnostics = #2 res}) end fun scanDir (f: string -> bool) (path: string) = @@ -518,79 +547,56 @@ fun handleDocumentDidChange (state: state) (toclient: LspSpec.toclient) (p: LspS (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 - insertFileState state fileName { text = newtext - , decls = #decls s - , envBeforeThisModule = #envBeforeThisModule s} - end + State.insertText fileName (List.foldl applyContentChange (#text s) (#contentChanges p)) end -fun handleDocumentDidClose (state: state) (toclient: LspSpec.toclient) (p: LspSpec.didCloseParams): unit = - let - val fileName = #path (#uri (#textDocument p)) - val s = SM.find (#fileStates state, fileName) - in - stateRef := SOME { urpPath = #urpPath state - , fileStates = (#1 (SM.remove (#fileStates state, fileName))) handle ex => #fileStates state - } - end +fun handleRequest (requestMessage: LspSpec.message) = + case requestMessage of + LspSpec.Notification n => + (LspSpec.matchNotification + n + { initialized = fn () => () + , textDocument_didOpen = + fn (p, toclient) => State.withState (fn state => + (State.insertText (#path (#uri (#textDocument p))) (#text (#textDocument p)) ; + elabFileAndSendDiags state toclient (#uri (#textDocument p)))) + , textDocument_didChange = + fn (p, toclient) => State.withState (fn state => handleDocumentDidChange state toclient p) + , textDocument_didSave = + fn (p, toclient) => State.withState (fn state => elabFileAndSendDiags state toclient (#uri (#textDocument p))) + , textDocument_didClose = + fn (p, toclient) => State.removeFile (#path (#uri (#textDocument p))) + }) + | LspSpec.RequestMessage m => + (* TODO should error handling here be inside handleMessage? *) + (LspSpec.matchMessage + m + { initialize = fn p => + (let val st = initState p + in + State.init st; + LspSpec.Success + { capabilities = + { hoverProvider = true + , completionProvider = SOME { triggerCharacters = ["."]} + , textDocumentSync = { openClose = true + , change = 2 + , save = SOME { includeText = false } + }} + } + end) + , shutdown = fn () => LspSpec.Success () + , textDocument_hover = fn toclient => State.withState handleHover + , textDocument_completion = State.withState handleCompletion + }) fun serverLoop () = let - val state = !stateRef val requestMessage = LspSpec.readRequestFromStdIO () handle ex => (debug (General.exnMessage ex) ; raise ex) in - case state of - NONE => - (case requestMessage of - LspSpec.RequestMessage m => - LspSpec.handleMessage - m - { initialize = fn p => - (let val st = initState p - in - stateRef := SOME st; - 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 toclient => fn _ => LspSpec.Error (~32002, "Server not initialized") - , textDocument_completion = fn _ => LspSpec.Error (~32002, "Server not initialized") - } - | LspSpec.Notification n => ()) - | SOME state => - (case requestMessage of - LspSpec.Notification n => - (LspSpec.handleNotification - n - { initialized = fn () => () - , 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 - , textDocument_didClose = fn toclient => fn p => handleDocumentDidClose state toclient p - }) - | LspSpec.RequestMessage m => - (* 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 toclient => handleHover state - , textDocument_completion = handleCompletion state - }) - ) + handleRequest requestMessage end fun startServer () = while true do serverLoop () diff --git a/src/lspspec.sml b/src/lspspec.sml index fe1711f0..bbc78606 100644 --- a/src/lspspec.sml +++ b/src/lspspec.sml @@ -1,6 +1,7 @@ structure LspSpec = struct datatype lspError = InternalError of string + | ServerNotInitialized exception LspError of lspError fun debug (str: string): unit = @@ -361,7 +362,7 @@ structure LspSpec = struct end val toclient: toclient = {showMessage = showMessage, publishDiagnostics = publishDiagnostics} - fun handleMessage + fun matchMessage (requestMessage: {id: Json.json, method: string, params: Json.json}) (handlers: messageHandlers) : unit = @@ -393,6 +394,7 @@ structure LspSpec = struct | method => (debug ("Method not supported: " ^ method); Error (~32601, "Method not supported: " ^ method))) handle LspError (InternalError str) => Error (~32603, str) + | LspError ServerNotInitialized => Error (~32002, "Server not initialized") | ex => Error (~32603, (General.exnMessage ex)) ) (* val () = (TextIO.output (TextIO.stdErr, "Got result: " ^ (case result of Success _ => "success\n" *) @@ -427,23 +429,24 @@ structure LspSpec = struct 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 + , textDocument_didOpen: (didOpenParams * toclient) -> unit + , textDocument_didChange: (didChangeParams * toclient) -> unit + , textDocument_didSave: (didSaveParams * toclient) -> unit + , textDocument_didClose: (didCloseParams * toclient) -> unit } - fun handleNotification + fun matchNotification (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)) + | "textDocument/didOpen" => (#textDocument_didOpen handlers) (parseDidOpenParams (#params notification), toclient) + | "textDocument/didChange" => (#textDocument_didChange handlers) (parseDidChangeParams (#params notification), toclient) + | "textDocument/didSave" => (#textDocument_didSave handlers) (parseDidSaveParams (#params notification), toclient) + | "textDocument/didClose" => (#textDocument_didClose handlers) (parseDidCloseParams (#params notification), toclient) | m => debug ("Notification method not supported: " ^ m)) handle LspError (InternalError str) => showMessage str 1 + | LspError ServerNotInitialized => showMessage "Server not initialized" 1 | ex => showMessage (General.exnMessage ex) 1 end -- cgit v1.2.3 From 586ebe1d29c591aa735e3ed9b7bfc1b1407b3d69 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Sun, 15 Dec 2019 10:20:47 +0100 Subject: Added background threads --- src/bg_thread.sig | 7 ++++ src/bg_thread.sml | 67 ++++++++++++++++++++++++++++++++ src/lsp.sml | 111 ++++++++++++++++++++++++++++++++---------------------- src/sources | 4 ++ 4 files changed, 144 insertions(+), 45 deletions(-) create mode 100644 src/bg_thread.sig create mode 100644 src/bg_thread.sml (limited to 'src/lsp.sml') diff --git a/src/bg_thread.sig b/src/bg_thread.sig new file mode 100644 index 00000000..5455bbc8 --- /dev/null +++ b/src/bg_thread.sig @@ -0,0 +1,7 @@ +(* Notice: API is kinda bad. We only allow queuing a single task per file *) +(* This works for us because we only do elaboration in the background, nothing else *) +signature BGTHREAD = sig + val queueBgTask: string (* fileName *) -> (unit -> unit) -> unit + val hasBgTasks: unit -> bool + val runBgTaskForABit: unit -> unit +end diff --git a/src/bg_thread.sml b/src/bg_thread.sml new file mode 100644 index 00000000..c5eb723c --- /dev/null +++ b/src/bg_thread.sml @@ -0,0 +1,67 @@ +(* Notice: API is kinda bad. We only allow queuing a single task per file *) +(* This works for us because we only do elaboration in the background, nothing else *) + +structure BgThread:> BGTHREAD = struct + open Posix.Signal + open MLton + open Itimer Signal Thread + + val debug = LspSpec.debug + + val topLevel: Thread.Runnable.t option ref = ref NONE + val currentRunningThreadIsForFileName: string ref = ref "" + (* FIFO queue: Max one task per fileName *) + val tasks: ((Thread.Runnable.t * string) list) ref = ref [] + fun hasBgTasks () = List.length (!tasks) > 0 + + fun setItimer t = + Itimer.set (Itimer.Real, + {value = t, + interval = t}) + + + fun done () = Thread.atomically + (fn () => + ( tasks := (List.filter (fn q => #2 q <> (!currentRunningThreadIsForFileName)) (!tasks)) + ; case !tasks of + [] => (setItimer Time.zeroTime + ; currentRunningThreadIsForFileName := "" + ; switch (fn _ => valOf (!topLevel))) + | t :: rest => (currentRunningThreadIsForFileName := #2 t + ; switch (fn _ => #1 t)))) + + fun queueBgTask fileName f = + let + fun new (f: unit -> unit): Thread.Runnable.t = + Thread.prepare + (Thread.new (fn () => ((f () handle _ => done ()) + ; done ())), + ()) + in + case List.find (fn t => #2 t = fileName) (!tasks) of + NONE => tasks := (new f, fileName) :: (!tasks) + | SOME t => + (* Move existing task to front of list *) + tasks := t :: List.filter (fn q => #2 q <> fileName) (!tasks) + end + + fun replaceInList (l: 'a list) (f: 'a -> bool) (replacement: 'a) = + List.map (fn a => if f a then replacement else a ) l + fun runBgTaskForABit () = + case !(tasks) of + [] => () + | t :: rest => + (setHandler (alrm, Handler.handler (fn t => (setItimer Time.zeroTime + (* This might some not needed, but other wise you get "Dead thread" error *) + ; tasks := replaceInList + (!tasks) + (fn t => #2 t = (!currentRunningThreadIsForFileName)) + (t, (!currentRunningThreadIsForFileName)) + ; currentRunningThreadIsForFileName := "" + ; valOf (!topLevel)))) + ; setItimer (Time.fromMilliseconds 200) + ; currentRunningThreadIsForFileName := #2 t + ; switch (fn top => (topLevel := SOME (Thread.prepare (top, ())); #1 t)) (* store top level thread and activate BG thread *) + ; setItimer Time.zeroTime + ) + end diff --git a/src/lsp.sml b/src/lsp.sml index 23b54a28..79b96ef9 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -480,7 +480,7 @@ fun findMatchingStringInEnv (env: ElabEnv.env) (str: string): LspSpec.completion , l2_) , _)) , l1_)) :: _ => - (debug "!!"; getCompletionsFromFields env (name ^ ".") (Substring.string str) fields) + getCompletionsFromFields env (name ^ ".") (Substring.string str) fields | _ => []) end | _ => @@ -500,13 +500,10 @@ fun handleCompletion (state: state) (p: LspSpec.completionReq) = 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 @@ -550,54 +547,78 @@ fun handleDocumentDidChange (state: state) (toclient: LspSpec.toclient) (p: LspS State.insertText fileName (List.foldl applyContentChange (#text s) (#contentChanges p)) end +fun runInBackground toclient (fileName: string) (f: unit -> unit): unit = + BgThread.queueBgTask + fileName + ((fn () => (f () + handle LspSpec.LspError (LspSpec.InternalError str) => (#showMessage toclient) str 1 + | LspSpec.LspError LspSpec.ServerNotInitialized => (#showMessage toclient) "Server not initialized" 1 + | ex => (#showMessage toclient) (General.exnMessage ex) 1 + ; (#showMessage toclient) ("Done running BG job for " ^ fileName) 3 + ))) + fun handleRequest (requestMessage: LspSpec.message) = case requestMessage of LspSpec.Notification n => - (LspSpec.matchNotification - n - { initialized = fn () => () - , textDocument_didOpen = - fn (p, toclient) => State.withState (fn state => - (State.insertText (#path (#uri (#textDocument p))) (#text (#textDocument p)) ; - elabFileAndSendDiags state toclient (#uri (#textDocument p)))) - , textDocument_didChange = - fn (p, toclient) => State.withState (fn state => handleDocumentDidChange state toclient p) - , textDocument_didSave = - fn (p, toclient) => State.withState (fn state => elabFileAndSendDiags state toclient (#uri (#textDocument p))) - , textDocument_didClose = - fn (p, toclient) => State.removeFile (#path (#uri (#textDocument p))) - }) + LspSpec.matchNotification + n + { initialized = fn () => () + , textDocument_didOpen = + fn (p, toclient) => + (State.insertText (#path (#uri (#textDocument p))) (#text (#textDocument p)); + runInBackground + toclient + (#path (#uri (#textDocument p))) + (fn () => State.withState (fn state => elabFileAndSendDiags state toclient (#uri (#textDocument p))))) + , textDocument_didChange = + fn (p, toclient) => + State.withState (fn state => handleDocumentDidChange state toclient p) + , textDocument_didSave = + fn (p, toclient) => + runInBackground + toclient + (#path (#uri (#textDocument p))) + (fn () => State.withState (fn state => elabFileAndSendDiags state toclient (#uri (#textDocument p)))) + , textDocument_didClose = + fn (p, toclient) => + State.removeFile (#path (#uri (#textDocument p))) + } | LspSpec.RequestMessage m => (* TODO should error handling here be inside handleMessage? *) - (LspSpec.matchMessage - m - { initialize = fn p => - (let val st = initState p - in - State.init st; - LspSpec.Success - { capabilities = - { hoverProvider = true - , completionProvider = SOME { triggerCharacters = ["."]} - , textDocumentSync = { openClose = true - , change = 2 - , save = SOME { includeText = false } - }} - } - end) - , shutdown = fn () => LspSpec.Success () - , textDocument_hover = fn toclient => State.withState handleHover - , textDocument_completion = State.withState handleCompletion - }) + LspSpec.matchMessage + m + { initialize = fn p => + (let val st = initState p + in + State.init st; + LspSpec.Success + { capabilities = + { hoverProvider = true + , completionProvider = SOME { triggerCharacters = ["."]} + , textDocumentSync = { openClose = true + , change = 2 + , save = SOME { includeText = false } + }} + } + end) + , shutdown = fn () => LspSpec.Success () + , textDocument_hover = fn toclient => State.withState handleHover + , textDocument_completion = fn p => State.withState (fn s => handleCompletion s p) + } fun serverLoop () = - let - val requestMessage = - LspSpec.readRequestFromStdIO () - handle ex => (debug (General.exnMessage ex) ; raise ex) - in - handleRequest requestMessage - end + if not (Option.isSome (TextIO.canInput (TextIO.stdIn, 1))) andalso BgThread.hasBgTasks () + then + (* no input waiting -> give control to lower prio thread *) + BgThread.runBgTaskForABit () + else + let + val requestMessage = + LspSpec.readRequestFromStdIO () + handle ex => (debug ("Error in reading from stdIn: " ^ General.exnMessage ex) ; raise ex) + in + handleRequest requestMessage + end fun startServer () = while true do serverLoop () end diff --git a/src/sources b/src/sources index 74171365..686832cc 100644 --- a/src/sources +++ b/src/sources @@ -285,6 +285,10 @@ $(SRC)/fromjson.sml $(SRC)/lspspec.sml +$(SML_LIB)/basis/mlton.mlb +$(SRC)/bg_thread.sig +$(SRC)/bg_thread.sml + $(SRC)/lsp.sig $(SRC)/lsp.sml -- cgit v1.2.3 From 472f3cf5206a06f0a7eae721f08f0a43276863cf Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Sat, 4 Jan 2020 13:58:50 +0100 Subject: Added some more stuff to lsp getInfo and completions --- src/getinfo.sml | 221 ++++++++++++++++++++++++++++++++++++++++++++++---------- src/lsp.sml | 36 +++++---- 2 files changed, 203 insertions(+), 54 deletions(-) (limited to 'src/lsp.sml') diff --git a/src/getinfo.sml b/src/getinfo.sml index 1d657637..abe3bc61 100644 --- a/src/getinfo.sml +++ b/src/getinfo.sml @@ -102,6 +102,43 @@ fun getInfo env str fileName {line = row, character = col} = else env) env decls | _ => env) + (* This isn't very precise since we use the span of the parent exp/decl/etc *) + (* to find the "smallest part" *) + fun printPat env (pat: L.pat) = + if isPosIn fileName row col (#2 pat) + then + case #1 pat of + L.PVar (str, c) => SOME (P.box [ P.PD.string str + , P.PD.string " : " + , ElabPrint.p_con env c]) + | L.PCon (_, _, _, SOME p) => printPat env p + | L.PRecord fields => (case List.mapPartial (fn field => printPat env (#2 field)) fields of + [] => NONE + | first :: _ => SOME first) + | _ => NONE + else NONE + + fun isXmlTag env c = + case c of + L.CApp + ((L.CApp + ((L.CApp + (( L.CApp + (( L.CApp + ((L.CNamed n, _) , _) + , _) + , _) + , _) + , _) + , _) + , _) + , _) + , _) => + (case E.lookupCNamed env n of + ("tag", _, _) => true + | _ => false) + | _ => false + (* 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 *) @@ -109,57 +146,164 @@ fun getInfo env str fileName {line = row, character = col} = fun printGoodPart env f span = (case f of Exp (L.EPrim p, _) => - SOME (P.box [Prim.p_t p, - P.PD.string ": ", - P.PD.string (case p of - Prim.Int _ => "int" - | Prim.Float _ => "float" - | Prim.String _ => "string" - | Prim.Char _ => "char")]) + let + val rendered = P.box [Prim.p_t p, + P.PD.string " : ", + P.PD.string (case p of + Prim.Int _ => "int" + | Prim.Float _ => "float" + | Prim.String _ => "string" + | Prim.Char _ => "char")] + in + case p of + Prim.String (_, str) => + if Substring.foldl (fn (c, acc) => acc andalso c = #" ") true (Substring.full str) + then NONE + else SOME rendered + | _ => SOME (rendered) + end | Exp (L.ERel n, _) => SOME ((let val found = E.lookupERel env n in P.box [ P.PD.string (#1 found) - , P.PD.string ": " + , P.PD.string " : " , ElabPrint.p_con env (#2 found)] end) handle E.UnboundRel _ => P.PD.string ("UNBOUND_REL" ^ Int.toString n)) - | Exp (L.ENamed n, _) => - SOME ((let val found = E.lookupENamed env n - in - P.box [ P.PD.string (#1 found) - , P.PD.string ": " - , ElabPrint.p_con env (#2 found)] - end) - handle E.UnboundNamed _ => P.PD.string ("UNBOUND_NAMED" ^ Int.toString n)) + | Exp (L.ENamed n, span) => + ((let + val found = E.lookupENamed env n + val rendered = P.box [ P.PD.string (#1 found) + , P.PD.string " : " + , ElabPrint.p_con env (#2 found) + ] + (* val () = if #1 found = "body" *) + (* then Print.eprint (ElabPrint.p_con env (#2 found)) *) + (* else () *) + in + (* case #2 found of *) + (* (L.TFun ((L.CUnit, _), (c, _)), _) => *) + (* (if isXmlTag env c *) + (* then SOME (P.box [ P.PD.string "<" *) + (* , P.PD.string ( #1 found) *) + (* , P.PD.string ">" *) + (* ]) *) + (* else SOME rendered) *) + (* | _ => *) SOME rendered + end) + handle E.UnboundNamed _ => SOME (P.PD.string ("UNBOUND_NAMED" ^ Int.toString n))) + | Exp (L.EAbs (varName, domain, _, _), _) => + if isPosIn fileName row col (#2 domain) + then + SOME (P.box [ P.PD.string (varName ^ " : ") + , ElabPrint.p_con env domain + ]) + else NONE + | Exp (L.EField (e, c, {field, ...}), loc) => + SOME (P.box [ElabPrint.p_exp env e, + P.PD.string ".", + ElabPrint.p_con env c, + P.PD.string ": ", + ElabPrint.p_con env field]) | Exp (L.EModProj ( m1 (* number (= "name") of top level module *) - , ms (* names of submodules - possibly none *) - , x (* identifier *)), loc) => - SOME (let - val (m1name, m1sgn) = E.lookupStrNamed env m1 - val (str, sgn) = foldl (fn (m, (str, sgn)) => - case E.projectStr env {sgn = sgn, str = str, field = m} of - NONE => raise Fail ("Couldn't find Structure: " ^ m) - | SOME sgn => ((L.StrProj (str, m), loc), sgn)) - ((L.StrVar m1, loc), m1sgn) - ms - val t = case E.projectVal env {sgn = sgn, str = str, field = x} of - NONE => raise Fail ("Couldn't find identifier: " ^ x) - | SOME t => t - in - P.box [ P.p_list_sep (P.PD.string ".") P.PD.string (m1name :: ms @ [x]) - , P.PD.string ": " - , ElabPrint.p_con env t - ] - end - handle E.UnboundNamed _ => P.PD.string ("Module not found: " ^ Int.toString m1)) + , ms (* names of submodules - possibly none *) + , x (* identifier *)), loc) => + (let + val (m1name, m1sgn) = E.lookupStrNamed env m1 + val (str, sgn) = foldl (fn (m, (str, sgn)) => + case E.projectStr env {sgn = sgn, str = str, field = m} of + NONE => raise Fail ("Couldn't find Structure: " ^ m) + | SOME sgn => ((L.StrProj (str, m), loc), sgn)) + ((L.StrVar m1, loc), m1sgn) + ms + val t = case E.projectVal env {sgn = sgn, str = str, field = x} of + NONE => raise Fail ("Couldn't find identifier: " ^ x) + | SOME t => t + in + case (m1name, x) of + (* Stripping these because XML desugaring adds these with small spans and crowd out the stuff you want to see *) + ("Basis", "cdata") => NONE + | ("Top", "txt") => NONE + | ("Basis", "join") => NONE + | ("Basis", "bind") => NONE + | ("Basis", "sql_subset") => NONE + | ("Basis", "sql_subset_all") => NONE + | ("Basis", "sql_query") => NONE + | ("Basis", "sql_query1") => NONE + | ("Basis", "sql_eq") => NONE + | ("Basis", "sql_inner_join") => NONE + (* | ("Basis", "sql_field") => NONE *) + | ("Basis", "sql_binary") => NONE + | _ => + SOME (P.box [ P.p_list_sep (P.PD.string ".") P.PD.string (m1name :: ms @ [x]) + , P.PD.string " : " + , ElabPrint.p_con env t + ]) + end + handle E.UnboundNamed _ => SOME (P.PD.string ("Module not found: " ^ Int.toString m1))) + | Exp (L.ELet (edecls, _, _), _) => + let + val found = List.mapPartial + (fn (edecl, loc) => + if isPosIn fileName row col loc + then + case edecl of + L.EDVal (pat, _, _) => printPat env pat + | L.EDValRec ((x, c, _) :: _) => + SOME (P.box [ P.PD.string x + , P.PD.string " : " + , ElabPrint.p_con env c]) + | _ => NONE + else NONE) + edecls + in + if List.length found > 0 + then SOME (List.hd found) + else NONE + end + | Exp (L.ECase (_, pats, _), _) => + (case List.find (fn ((pat', loc), exp) => isPosIn fileName row col loc) pats of + NONE => NONE + | SOME (pat, _) => printPat env pat) | Exp e => NONE | Kind k => NONE | Con c => NONE | Sgn_item si => NONE | Sgn s => NONE | Str s => NONE - | Decl d => NONE) + | Decl (L.DVal (x, _, con, _), _) => + SOME (P.box [ P.PD.string x + , P.PD.string " : " + , ElabPrint.p_con env con ]) + | Decl (L.DValRec decls, _) => + (* valrecs don't have nice spans per declaration so we find the *) + (* declaration for which the con starts closest *) + let + val res = + List.foldl (fn (decl, accO) => + let + val distanceFromRow = Int.abs (#line (#first (#2 (#3 decl))) - row) + val accDistanceFromRow = case accO of + NONE => 999 + | SOME acc => Int.abs (#line (#first (#2 (#3 acc))) - row) + in + if distanceFromRow < accDistanceFromRow andalso distanceFromRow <= 1 + then SOME decl + else accO + end) + NONE + decls + in + case res of + NONE => NONE + | SOME (x, _, con, _) => + SOME (P.box [ P.PD.string x + , P.PD.string " : " + , ElabPrint.p_con env con + ]) + end + | Decl d => NONE + ) fun add (env: ElabEnv.env) (item: item) (span: ErrorMsg.span) (acc: { smallest : { span : ErrorMsg.span , item : item @@ -187,7 +331,8 @@ fun getInfo env str fileName {line = row, character = col} = NONE => NONE | 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' + if + isSmallerThan span span' then (case printGoodPart env item span of NONE => SOME prev diff --git a/src/lsp.sml b/src/lsp.sml index 79b96ef9..e00bd850 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -465,23 +465,27 @@ fun findMatchingStringInEnv (env: ElabEnv.env) (str: string): LspSpec.completion (* TODO PERF SMALL: first match and then equal is not perfect *) val foundEs = ElabEnv.matchEByPrefix env (Substring.string r) val filteredEs = List.filter (fn (name,_) => name = Substring.string r) foundEs + val reduced = List.map (fn (name, c) => + (name, ElabOps.reduceCon env c) + handle ex => (name, (Elab.CUnit, ErrorMsg.dummySpan))) + filteredEs in - (case List.map (fn (name, c) => (name, ElabOps.reduceCon env c)) filteredEs of - [] => [] - | (name, (Elab.TRecord (Elab.CRecord (_, fields), l2_), l1_)) :: _ => - getCompletionsFromFields env (name ^ ".") (Substring.string str) fields - | (name, (* TODO this doesn't always work. I've only managed to get it working for tables in a different module *) - ( ( Elab.CApp - ( ( (Elab.CApp - ( ( Elab.CModProj (_, _, "sql_table") - , l4_) - , ( Elab.CRecord (_, fields) - , l3_))) - , l2_) - , _)) - , l1_)) :: _ => - getCompletionsFromFields env (name ^ ".") (Substring.string str) fields - | _ => []) + case reduced of + [] => [] + | (name, (Elab.TRecord (Elab.CRecord (_, fields), l2_), l1_)) :: _ => + getCompletionsFromFields env (name ^ ".") (Substring.string str) fields + | (name, + ( ( Elab.CApp + ( ( (Elab.CApp + ( ( Elab.CModProj (_, _, "sql_table") + , l4_) + , ( Elab.CRecord (_, fields) + , l3_))) + , l2_) + , _)) + , l1_)) :: _ => + getCompletionsFromFields env (name ^ ".") (Substring.string str) fields + | _ => [] end | _ => (* TODO NOTIMPLEMENTED submodules / nested records *) -- cgit v1.2.3 From cffbd03336348508dfb8d647a593c24b9bc89878 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Wed, 8 Jan 2020 10:13:39 +0100 Subject: Return only unique diags + better formatting --- src/getinfo.sml | 67 ++++++++++++++++++++++++++------------------------------- src/lsp.sml | 9 +++++++- 2 files changed, 39 insertions(+), 37 deletions(-) (limited to 'src/lsp.sml') diff --git a/src/getinfo.sml b/src/getinfo.sml index abe3bc61..d980afd3 100644 --- a/src/getinfo.sml +++ b/src/getinfo.sml @@ -138,6 +138,12 @@ fun getInfo env str fileName {line = row, character = col} = ("tag", _, _) => true | _ => false) | _ => false + + fun formatTypeBox (a: P.PD.pp_desc, b: P.PD.pp_desc) = + P.PD.hvBox (P.PD.PPS.Rel 0, [a, + P.PD.string ": ", + P.PD.break {nsp = 0, offset = 2}, + b]) (* TODO We lose some really useful information, like eg. inferred parameters, *) (* which we do have in the actual items (L.Decl, L.Exp, etc) *) @@ -147,13 +153,12 @@ fun getInfo env str fileName {line = row, character = col} = (case f of Exp (L.EPrim p, _) => let - val rendered = P.box [Prim.p_t p, - P.PD.string " : ", - P.PD.string (case p of - Prim.Int _ => "int" - | Prim.Float _ => "float" - | Prim.String _ => "string" - | Prim.Char _ => "char")] + val rendered = formatTypeBox ( Prim.p_t p + , P.PD.string (case p of + Prim.Int _ => "int" + | Prim.Float _ => "float" + | Prim.String _ => "string" + | Prim.Char _ => "char")) in case p of Prim.String (_, str) => @@ -165,18 +170,15 @@ fun getInfo env str fileName {line = row, character = col} = | Exp (L.ERel n, _) => SOME ((let val found = E.lookupERel env n in - P.box [ P.PD.string (#1 found) - , P.PD.string " : " - , ElabPrint.p_con env (#2 found)] + formatTypeBox ( P.PD.string (#1 found) + , ElabPrint.p_con env (#2 found)) end) handle E.UnboundRel _ => P.PD.string ("UNBOUND_REL" ^ Int.toString n)) | Exp (L.ENamed n, span) => ((let val found = E.lookupENamed env n - val rendered = P.box [ P.PD.string (#1 found) - , P.PD.string " : " - , ElabPrint.p_con env (#2 found) - ] + val rendered = formatTypeBox ( P.PD.string (#1 found) + , ElabPrint.p_con env (#2 found)) (* val () = if #1 found = "body" *) (* then Print.eprint (ElabPrint.p_con env (#2 found)) *) (* else () *) @@ -195,16 +197,15 @@ fun getInfo env str fileName {line = row, character = col} = | Exp (L.EAbs (varName, domain, _, _), _) => if isPosIn fileName row col (#2 domain) then - SOME (P.box [ P.PD.string (varName ^ " : ") - , ElabPrint.p_con env domain - ]) + SOME (formatTypeBox ( P.PD.string varName + , ElabPrint.p_con env domain) + ) else NONE | Exp (L.EField (e, c, {field, ...}), loc) => - SOME (P.box [ElabPrint.p_exp env e, - P.PD.string ".", - ElabPrint.p_con env c, - P.PD.string ": ", - ElabPrint.p_con env field]) + SOME (formatTypeBox ( P.box [ElabPrint.p_exp env e, + P.PD.string ".", + ElabPrint.p_con env c] + , ElabPrint.p_con env field)) | Exp (L.EModProj ( m1 (* number (= "name") of top level module *) , ms (* names of submodules - possibly none *) , x (* identifier *)), loc) => @@ -235,10 +236,8 @@ fun getInfo env str fileName {line = row, character = col} = (* | ("Basis", "sql_field") => NONE *) | ("Basis", "sql_binary") => NONE | _ => - SOME (P.box [ P.p_list_sep (P.PD.string ".") P.PD.string (m1name :: ms @ [x]) - , P.PD.string " : " - , ElabPrint.p_con env t - ]) + SOME (formatTypeBox ( P.p_list_sep (P.PD.string ".") P.PD.string (m1name :: ms @ [x]) + , ElabPrint.p_con env t)) end handle E.UnboundNamed _ => SOME (P.PD.string ("Module not found: " ^ Int.toString m1))) | Exp (L.ELet (edecls, _, _), _) => @@ -250,9 +249,8 @@ fun getInfo env str fileName {line = row, character = col} = case edecl of L.EDVal (pat, _, _) => printPat env pat | L.EDValRec ((x, c, _) :: _) => - SOME (P.box [ P.PD.string x - , P.PD.string " : " - , ElabPrint.p_con env c]) + SOME (formatTypeBox ( P.PD.string x + , ElabPrint.p_con env c)) | _ => NONE else NONE) edecls @@ -272,9 +270,8 @@ fun getInfo env str fileName {line = row, character = col} = | Sgn s => NONE | Str s => NONE | Decl (L.DVal (x, _, con, _), _) => - SOME (P.box [ P.PD.string x - , P.PD.string " : " - , ElabPrint.p_con env con ]) + SOME (formatTypeBox ( P.PD.string x + , ElabPrint.p_con env con )) | Decl (L.DValRec decls, _) => (* valrecs don't have nice spans per declaration so we find the *) (* declaration for which the con starts closest *) @@ -297,10 +294,8 @@ fun getInfo env str fileName {line = row, character = col} = case res of NONE => NONE | SOME (x, _, con, _) => - SOME (P.box [ P.PD.string x - , P.PD.string " : " - , ElabPrint.p_con env con - ]) + SOME (formatTypeBox ( P.PD.string x + , ElabPrint.p_con env con)) end | Decl d => NONE ) diff --git a/src/lsp.sml b/src/lsp.sml index e00bd850..ef12bbac 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -258,16 +258,23 @@ fun elabFile (state: state) (fileName: string): ({ decls: Elab.decl list, envBef end end +fun uniq (comp: 'b -> 'b -> bool) (bs: 'b list) = + case bs of + [] => [] + | (l as b :: bs') => b :: uniq comp (List.filter (comp b) bs') + fun elabFileAndSendDiags (state: state) (toclient: LspSpec.toclient) (documentUri: LspSpec.documentUri): unit = let val fileName = #path documentUri val res = elabFile state fileName + fun eq_diag d1 d2 = #range d1 = #range d2 andalso #message d1 = #message d2 + val diags = uniq eq_diag (#2 res) in (case #1 res of NONE => () | SOME fs => (State.insertElabRes fileName (#envBeforeThisModule fs) (#decls fs)); - #publishDiagnostics toclient { uri = documentUri , diagnostics = #2 res}) + #publishDiagnostics toclient { uri = documentUri , diagnostics = diags}) end fun scanDir (f: string -> bool) (path: string) = -- cgit v1.2.3 From 7ebc4f3ff8081424f0e227142ac76bb3f7fc4a20 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Wed, 8 Jan 2020 12:11:18 +0100 Subject: Added some type sigs required by SMLNJ --- src/getinfo.sml | 2 +- src/lsp.sml | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'src/lsp.sml') diff --git a/src/getinfo.sml b/src/getinfo.sml index d980afd3..d84f792b 100644 --- a/src/getinfo.sml +++ b/src/getinfo.sml @@ -32,7 +32,7 @@ structure E = ElabEnv structure L = Elab structure P = Print -fun isPosIn file row col span = +fun isPosIn (file: string) (row: int) (col: int) (span: ErrorMsg.span) = let val start = #first span val end_ = #last span diff --git a/src/lsp.sml b/src/lsp.sml index ef12bbac..d11aab3f 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -267,7 +267,7 @@ fun elabFileAndSendDiags (state: state) (toclient: LspSpec.toclient) (documentUr let val fileName = #path documentUri val res = elabFile state fileName - fun eq_diag d1 d2 = #range d1 = #range d2 andalso #message d1 = #message d2 + fun eq_diag (d1: LspSpec.diagnostic) (d2: LspSpec.diagnostic) = #range d1 = #range d2 andalso #message d1 = #message d2 val diags = uniq eq_diag (#2 res) in (case #1 res of @@ -558,7 +558,7 @@ fun handleDocumentDidChange (state: state) (toclient: LspSpec.toclient) (p: LspS State.insertText fileName (List.foldl applyContentChange (#text s) (#contentChanges p)) end -fun runInBackground toclient (fileName: string) (f: unit -> unit): unit = +fun runInBackground (toclient: LspSpec.toclient) (fileName: string) (f: unit -> unit): unit = BgThread.queueBgTask fileName ((fn () => (f () -- cgit v1.2.3 From d7ca451f01595ced7cfe70f43714ac2a1150915d Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Wed, 8 Jan 2020 12:11:45 +0100 Subject: Allow simple .ur files to double as .urs files for LSP --- src/lsp.sml | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) (limited to 'src/lsp.sml') diff --git a/src/lsp.sml b/src/lsp.sml index d11aab3f..856b7ab8 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -180,18 +180,16 @@ fun elabFile (state: state) (fileName: string): ({ decls: Elab.decl list, envBef 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 - val fileName = entry ^ ".urs" - in - { fileName = fileName - , parsed = - if OS.FileSys.access (fileName, []) - then case C.run (C.transform C.parseUrs "parseUrs") fileName of - NONE => raise LspSpec.LspError (LspSpec.InternalError ("Failed to parse .urs file at " ^ fileName)) - | SOME a => a - else raise LspSpec.LspError (LspSpec.InternalError ("Couldn't find an .urs file for " ^ fileName)) - } - end) + if OS.FileSys.access (entry ^ ".urs", []) + then case C.run (C.transform C.parseUrs "parseUrs") (entry ^ ".urs") of + NONE => raise LspSpec.LspError (LspSpec.InternalError ("Failed to parse .urs file at " ^ entry)) + | SOME a => { fileName = entry ^ ".urs", parsed = a} + else + if OS.FileSys.access (entry ^ ".ur", []) + then case C.run (C.transform C.parseUrs "parseUrs") (entry ^ ".ur") of + NONE => raise LspSpec.LspError (LspSpec.InternalError ("No .urs file found for " ^ entry ^ " and couldn't parse .ur as .urs file")) + | SOME a => { fileName = entry ^ ".ur" , parsed = a} + else raise LspSpec.LspError (LspSpec.InternalError ("Couldn't find an .ur or .urs file for " ^ entry))) modulesBeforeThisFile (* Parsing Basis and Top *) val basisF = Settings.libFile "basis.urs" -- cgit v1.2.3 From ce6bae891c6d1e22e61a1fb54ce3ecd08ca31891 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Fri, 10 Jan 2020 02:25:45 +0100 Subject: Refactor to do all matching on strings, more precise and faster --- src/elab_env.sig | 6 +- src/elab_env.sml | 28 ++- src/getinfo.sig | 34 ++-- src/getinfo.sml | 511 ++++++++++++++++++++++--------------------------------- src/lsp.sml | 229 ++++++------------------- 5 files changed, 291 insertions(+), 517 deletions(-) (limited to 'src/lsp.sml') diff --git a/src/elab_env.sig b/src/elab_env.sig index fb95d68e..4f994221 100644 --- a/src/elab_env.sig +++ b/src/elab_env.sig @@ -61,7 +61,6 @@ signature ELAB_ENV = sig val lookupCNamed : env -> int -> string * Elab.kind * Elab.con option val lookupC : env -> string -> Elab.kind var - val matchCByPrefix: env -> string -> (string * Elab.kind) list val pushDatatype : env -> int -> string list -> (string * int * Elab.con option) list -> env type datatyp @@ -86,7 +85,6 @@ 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 matchEByPrefix: env -> string -> (string * Elab.con) list val lookupE : env -> string -> Elab.con var @@ -102,8 +100,10 @@ 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 dumpCs: env -> (string * Elab.kind) list + val dumpEs: env -> (string * Elab.con) list + val dumpStrs: env -> (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 f492bc94..5fa32cd2 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -404,14 +404,6 @@ fun lookupC (env : env) x = | SOME (Rel' x) => Rel x | SOME (Named' x) => Named x -fun matchCByPrefix (env: env) (prefix: string): (string * kind) list = - List.mapPartial (fn (name, value) => if String.isPrefix prefix name - then case value of - Rel' (_, x) => SOME (name, x) - | Named' (_, x) => SOME (name, x) - else NONE) - (SM.listItemsi (#renameC env)) - fun pushDatatype (env : env) n xs xncs = let val dk = U.classifyDatatype xncs @@ -940,13 +932,6 @@ fun lookupENamed (env : env) n = NONE => raise UnboundNamed n | SOME x => x -(* TODO Why does this work better than using #renameE? *) -fun matchEByPrefix (env: env) (prefix: string): (string * con) list = - List.mapPartial (fn (name, value) => if String.isPrefix prefix name - then SOME (name, value) - else NONE) - (#relE env @ IM.listItems (#namedE env)) - fun checkENamed (env : env) n = Option.isSome (IM.find (#namedE env, n)) @@ -1000,8 +985,17 @@ 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 dumpCs (env: env): (string * kind) list = + List.map (fn (name, value) => case value of + Rel' (_, x) => (name, x) + | Named' (_, x) => (name, x)) + (SM.listItemsi (#renameC env)) +(* TODO try again with #renameE *) +fun dumpEs (env: env): (string * con) list = + #relE env @ IM.listItems (#namedE env) +fun dumpStrs (env: env) = + SM.listItemsi (#renameStr env) fun sgiSeek (sgi, (sgns, strs, cons)) = case sgi of diff --git a/src/getinfo.sig b/src/getinfo.sig index 50eee70a..663a9a81 100644 --- a/src/getinfo.sig +++ b/src/getinfo.sig @@ -27,28 +27,24 @@ 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 + datatype foundInEnv = FoundStr of (string * Elab.sgn) + | FoundCon of (string * Elab.kind) + | FoundExp of (string * Elab.con) - val getInfo: + val findStringInEnv: ElabEnv.env -> Elab.str' -> string (* fileName *) -> - { line: int , character: int} -> - { smallest : { span : ErrorMsg.span - , item : item - , env : ElabEnv.env } - , smallestgoodpart : { span : ErrorMsg.span - , desc : Print.PD.pp_desc - , env : ElabEnv.env - , item : item - } option -} + {line: int, char: int} -> + string (* query *) -> + (ElabEnv.env * string (* prefix *) * foundInEnv option) + + val matchStringInEnv: + ElabEnv.env -> + Elab.str' -> + string (* fileName *) -> + {line: int, char: int} -> + string (* query *) -> + (ElabEnv.env * string (* prefix *) * foundInEnv list) end diff --git a/src/getinfo.sml b/src/getinfo.sml index 5a0fe752..f18d0638 100644 --- a/src/getinfo.sml +++ b/src/getinfo.sml @@ -30,21 +30,19 @@ structure GetInfo :> GET_INFO = struct structure U = ElabUtilPos structure E = ElabEnv structure L = Elab -structure P = Print -fun isPosIn (file: string) (row: int) (col: int) (span: ErrorMsg.span) = +fun isPosIn (file: string) (line: int) (char: int) (span: ErrorMsg.span) = let val start = #first span val end_ = #last span in OS.Path.base file = OS.Path.base (#file span) andalso - (#line start < row orelse - #line start = row andalso #char start <= col) + (#line start < line orelse + #line start = line andalso #char start <= char) andalso - (#line end_ > row orelse - #line end_ = row andalso #char end_ >= col) - + (#line end_ > line orelse + #line end_ = line andalso #char end_ >= char) end fun isSmallerThan (s1: ErrorMsg.span) (s2: ErrorMsg.span) = @@ -63,8 +61,8 @@ datatype item = | Str of L.str | Decl of L.decl -fun getSpan (f: item * E.env) = - case #1 f of +fun getSpan (f: item) = + case f of Kind k => #2 k | Con c => #2 c | Exp e => #2 e @@ -73,310 +71,215 @@ 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} = +fun findInStr (f: ElabEnv.env -> item (* curr *) -> item (* prev *) -> bool) + (init: item) + env str fileName {line = line, char = char}: {item: item, env: ElabEnv.env} = let val () = U.mliftConInCon := E.mliftConInCon + val {env: ElabEnv.env, found: Elab.decl option} = + (case str of + L.StrConst decls => + List.foldl (fn (d, acc as {env, found}) => + if #line (#last (#2 d)) < line + then {env = E.declBinds env d, found = found} + else + if #line (#first (#2 d)) <= line andalso line <= #line (#last (#2 d)) + then {env = env, found = SOME d} + else {env = env, found = found}) + {env = env, found = NONE} decls + | _ => { env = env, found = NONE }) + val dummyResult = (init, env) + val result = + case found of + NONE => dummyResult + | SOME d => + U.Decl.foldB + { kind = fn (env, i, acc as (prev, env')) => if f env (Kind i) prev then (Kind i, env) else acc, + con = fn (env, i, acc as (prev, env')) => if f env (Con i) prev then (Con i, env) else acc, + exp = fn (env, i, acc as (prev, env')) => if f env (Exp i) prev then (Exp i, env) else acc, + sgn_item = fn (env, i, acc as (prev, env')) => if f env (Sgn_item i) prev then (Sgn_item i, env) else acc, + sgn = fn (env, i, acc as (prev, env')) => if f env (Sgn i) prev then (Sgn i, env) else acc, + str = fn (env, i, acc as (prev, env')) => if f env (Str i) prev then (Str i, env) else acc, + decl = fn (env, i, acc as (prev, env')) => if f env (Decl i) prev then (Decl i, env) else acc, + bind = fn (env, binder) => + case binder of + U.Decl.RelK x => E.pushKRel env x + | U.Decl.RelC (x, k) => E.pushCRel env x k + | U.Decl.NamedC (x, n, k, co) => E.pushCNamedAs env x n k co + | U.Decl.RelE (x, c) => E.pushERel env x c + | U.Decl.NamedE (x, c) => #1 (E.pushENamed env x c) + | U.Decl.Str (x, n, sgn) => #1 (E.pushStrNamed env x sgn) + | U.Decl.Sgn (x, n, sgn) => #1 (E.pushSgnNamed env x sgn) + } + env dummyResult d + in + {item = #1 result, env = #2 result} + end - (* Adding previous declarations in file to environment *) - (* "open " statements are already translated during elaboration *) - (* They get added to the env here "unprefixed" *) - val env = (case str of - L.StrConst decls => - List.foldl (fn (d, env) => - if #line (#first (#2 d)) <= row - andalso #char (#first (#2 d)) <= col - then E.declBinds env d - else env) env decls - | _ => env) +fun findSmallestSpan env str fileName {line = line, char = char} = + let + fun fitsAndIsSmaller (env: ElabEnv.env) (curr: item) (prev: item) = + isPosIn fileName line char (getSpan curr) andalso isSmallerThan (getSpan curr) (getSpan prev) + val init = Str (str, { file = fileName + , first = { line = 0, char = 0} + , last = { line = Option.getOpt (Int.maxInt, 99999), char = 0} }) + in + findInStr fitsAndIsSmaller init env str fileName {line = line, char = char} + end - (* This isn't very precise since we use the span of the parent exp/decl/etc *) - (* to find the "smallest part" *) - fun printPat env (pat: L.pat) = - if isPosIn fileName row col (#2 pat) - then - case #1 pat of - L.PVar (str, c) => SOME (P.box [ P.PD.string str - , P.PD.string " : " - , ElabPrint.p_con env c]) - | L.PCon (_, _, _, SOME p) => printPat env p - | L.PRecord fields => (case List.mapPartial (fn field => printPat env (#2 field)) fields of - [] => NONE - | first :: _ => SOME first) - | _ => NONE - else NONE +fun findFirstExpAfter env str fileName {line = line, char = char} = + let + fun currIsAfterPosAndBeforePrev (env: ElabEnv.env) (curr: item) (prev: item) = + (* curr is an exp *) + (case curr of Exp _ => true | _ => false) + andalso + (* curr is after input pos *) + ( line < #line (#first (getSpan curr)) + orelse ( line = #line (#first (getSpan curr)) + andalso char < #char (#first (getSpan curr)))) + andalso + (* curr is before prev *) + (#line (#first (getSpan curr)) < #line (#first (getSpan prev)) + orelse + (#line (#first (getSpan curr)) = #line (#first (getSpan prev)) + andalso #char (#first (getSpan curr)) < #char (#first (getSpan prev)))) + val init = Exp (Elab.EPrim (Prim.Int 0), + { file = fileName + , first = { line = Option.getOpt (Int.maxInt, 99999), char = Option.getOpt (Int.maxInt, 99999)} + , last = { line = Option.getOpt (Int.maxInt, 99999), char = Option.getOpt (Int.maxInt, 99999)} }) + in + findInStr currIsAfterPosAndBeforePrev init env str fileName {line = line, char = char} + end - fun isXmlTag env c = - case c of - L.CApp - ((L.CApp - ((L.CApp - (( L.CApp - (( L.CApp - ((L.CNamed n, _) , _) - , _) - , _) - , _) - , _) - , _) - , _) - , _) - , _) => - (case E.lookupCNamed env n of - ("tag", _, _) => true - | _ => false) - | _ => false - fun formatTypeBox (a: P.PD.pp_desc, b: P.PD.pp_desc) = - P.PD.hvBox (P.PD.PPS.Rel 0, [a, - P.PD.string ": ", - P.PD.break {nsp = 0, offset = 2}, - b]) - - (* 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 *) - (* TODO Rename? *) - fun printGoodPart env f span = - (case f of - Exp (L.EPrim p, _) => - let - val rendered = formatTypeBox ( Prim.p_t p - , P.PD.string (case p of - Prim.Int _ => "int" - | Prim.Float _ => "float" - | Prim.String _ => "string" - | Prim.Char _ => "char")) - in - case p of - Prim.String (_, str) => - if Substring.foldl (fn (c, acc) => acc andalso c = #" ") true (Substring.full str) - then NONE - else SOME rendered - | _ => SOME (rendered) - end - | Exp (L.ERel n, _) => - SOME ((let val found = E.lookupERel env n - in - formatTypeBox ( P.PD.string (#1 found) - , ElabPrint.p_con env (#2 found)) - end) - handle E.UnboundRel _ => P.PD.string ("UNBOUND_REL" ^ Int.toString n)) - | Exp (L.ENamed n, span) => - ((let - val found = E.lookupENamed env n - val rendered = formatTypeBox ( P.PD.string (#1 found) - , ElabPrint.p_con env (#2 found)) - (* val () = if #1 found = "body" *) - (* then Print.eprint (ElabPrint.p_con env (#2 found)) *) - (* else () *) - in - (* case #2 found of *) - (* (L.TFun ((L.CUnit, _), (c, _)), _) => *) - (* (if isXmlTag env c *) - (* then SOME (P.box [ P.PD.string "<" *) - (* , P.PD.string ( #1 found) *) - (* , P.PD.string ">" *) - (* ]) *) - (* else SOME rendered) *) - (* | _ => *) SOME rendered - end) - handle E.UnboundNamed _ => SOME (P.PD.string ("UNBOUND_NAMED" ^ Int.toString n))) - | Exp (L.EAbs (varName, domain, _, _), _) => - if isPosIn fileName row col (#2 domain) - then - SOME (formatTypeBox ( P.PD.string varName - , ElabPrint.p_con env domain) - ) - else NONE - | Exp (L.EField (e, c, {field, ...}), loc) => - SOME (formatTypeBox ( P.box [ElabPrint.p_exp env e, - P.PD.string ".", - ElabPrint.p_con env c] - , ElabPrint.p_con env field)) - | Exp (L.EModProj ( m1 (* number (= "name") of top level module *) - , ms (* names of submodules - possibly none *) - , x (* identifier *)), loc) => - (let - val (m1name, m1sgn) = E.lookupStrNamed env m1 - val (str, sgn) = foldl (fn (m, (str, sgn)) => - case E.projectStr env {sgn = sgn, str = str, field = m} of - NONE => raise Fail ("Couldn't find Structure: " ^ m) - | SOME sgn => ((L.StrProj (str, m), loc), sgn)) - ((L.StrVar m1, loc), m1sgn) - ms - val t = case E.projectVal env {sgn = sgn, str = str, field = x} of - NONE => raise Fail ("Couldn't find identifier: " ^ x) - | SOME t => t - in - case (m1name, x) of - (* Stripping these because XML desugaring adds these with small spans and crowd out the stuff you want to see *) - ("Basis", "cdata") => NONE - | ("Top", "txt") => NONE - | ("Basis", "join") => NONE - | ("Basis", "bind") => NONE - | ("Basis", "sql_subset") => NONE - | ("Basis", "sql_subset_all") => NONE - | ("Basis", "sql_query") => NONE - | ("Basis", "sql_query1") => NONE - | ("Basis", "sql_eq") => NONE - | ("Basis", "sql_inner_join") => NONE - (* | ("Basis", "sql_field") => NONE *) - | ("Basis", "sql_binary") => NONE - | _ => - SOME (formatTypeBox ( P.p_list_sep (P.PD.string ".") P.PD.string (m1name :: ms @ [x]) - , ElabPrint.p_con env t)) - end - handle E.UnboundNamed _ => SOME (P.PD.string ("Module not found: " ^ Int.toString m1))) - | Exp (L.ELet (edecls, _, _), _) => - let - val found = List.mapPartial - (fn (edecl, loc) => - if isPosIn fileName row col loc - then - case edecl of - L.EDVal (pat, _, _) => printPat env pat - | L.EDValRec ((x, c, _) :: _) => - SOME (formatTypeBox ( P.PD.string x - , ElabPrint.p_con env c)) - | _ => NONE - else NONE) - edecls - in - if List.length found > 0 - then SOME (List.hd found) - else NONE - end - | Exp (L.ECase (_, pats, _), _) => - (case List.find (fn ((pat', loc), exp) => isPosIn fileName row col loc) pats of - NONE => NONE - | SOME (pat, _) => printPat env pat) - | Exp e => NONE - | Kind k => NONE - | Con c => NONE - | Sgn_item si => NONE - | Sgn s => NONE - | Str s => NONE - | Decl (L.DVal (x, _, con, _), _) => - SOME (formatTypeBox ( P.PD.string x - , ElabPrint.p_con env con )) - | Decl (L.DValRec decls, _) => - (* valrecs don't have nice spans per declaration so we find the *) - (* declaration for which the con starts closest *) - let - val res = - List.foldl (fn (decl, accO) => - let - val distanceFromRow = Int.abs (#line (#first (#2 (#3 decl))) - row) - val accDistanceFromRow = case accO of - NONE => Option.getOpt (Int.maxInt, 99999) - | SOME acc => Int.abs (#line (#first (#2 (#3 acc))) - row) - in - if distanceFromRow < accDistanceFromRow andalso distanceFromRow <= 1 - then SOME decl - else accO - end) - NONE - decls - in - case res of - NONE => NONE - | SOME (x, _, con, _) => - SOME (formatTypeBox ( P.PD.string x - , ElabPrint.p_con env con)) - end - | Decl d => NONE - ) +datatype foundInEnv = FoundStr of (string * Elab.sgn) + | FoundCon of (string * Elab.kind) + | FoundExp of (string * Elab.con) - 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 - else - let - val smallest = - if isSmallerThan span (#span (#smallest acc)) - then {span = span, item = item, env = env} - else #smallest acc - val smallestgoodpart = - case #smallestgoodpart acc of - NONE => - (case printGoodPart env item span of - NONE => NONE - | 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 prev - | SOME desc => SOME {desc = desc, span = span, env = env, item = item}) - else SOME prev - in - {smallest = smallest, smallestgoodpart = smallestgoodpart} - end +fun getNameOfFoundInEnv (f: foundInEnv) = + case f of + FoundStr (x, _) => x + | FoundCon (x, _) => x + | FoundExp (x, _) => x - (* Look for item at input position *) - (* We're looking for two things simultaneously: *) - (* 1. The "smallest" part, ie. the one of which the source span is the smallest *) - (* 2. The "smallestgoodpart" part, ie. the one of which the source span is the smallest AND has a special case in printGoodPart *) - (* If we end up with a smallestgoodpart, we'll show that one since that one is probably more useful *) - (* TODO source spans of XML and SQL sources are weird and you end *) - (* up with eg: a span from eg 1-5 and another from 2-6, makes no sense? *) - (* That's one of the reasons why we're searching for the two things mentioned above *) - val result = - U.Decl.foldB - { kind = fn (env, (k, span), acc) => add env (Kind (k, span)) span acc, - con = fn (env, (k, span), acc) => add env (Con (k, span)) span acc, - exp = fn (env, (k, span), acc) => add env (Exp (k, span)) span acc, - sgn_item = fn (env, (k, span), acc) => add env (Sgn_item (k, span)) span acc, - sgn = fn (env, (k, span), acc) => add env (Sgn (k, span)) span acc, - str = fn (env, (k, span), acc) => add env (Str (k, span)) span acc, - decl = fn (env, (k, span), acc) => add env (Decl (k, span)) span acc, - bind = fn (env, binder) => - case binder of - U.Decl.RelK x => E.pushKRel env x - | U.Decl.RelC (x, k) => E.pushCRel env x k - | U.Decl.NamedC (x, n, k, co) => E.pushCNamedAs env x n k co - | U.Decl.RelE (x, c) => E.pushERel env x c - | U.Decl.NamedE (x, c) => #1 (E.pushENamed env x c) - | U.Decl.Str (x, n, sgn) => #1 (E.pushStrNamed env x sgn) - | U.Decl.Sgn (x, n, sgn) => #1 (E.pushSgnNamed env x sgn) - } - env - { smallestgoodpart = NONE - , smallest = { item = Str (str, { file = fileName - , first = { line = 0, char = 0} - , last = { line = Option.getOpt (Int.maxInt, 99999), char = 0} }) - , span = { file = fileName - , first = { line = 0, char = 0} - , last = { line = Option.getOpt (Int.maxInt, 99999), char = 0} } - , env = env } - } - ( 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}) +fun filterSgiItems (items: Elab.sgn_item list) : foundInEnv list = + let + fun mapF item = + case item of + (Elab.SgiVal (name, _, c), _) => [FoundExp (name, c)] + | (Elab.SgiCon (name, _, k, _), _) => [FoundCon (name, k)] + | (Elab.SgiDatatype ds, loc) => + List.concat (List.map (fn (dtx, i, _, cs) => + FoundExp (dtx, (Elab.CNamed i, loc)) + :: List.map (fn (x, i, _) => FoundExp (x, (Elab.CRel i, loc))) cs) ds) + | (Elab.SgiDatatypeImp (x, i, _, _, _, _, cs), loc) => + FoundExp (x, (Elab.CNamed i, loc)) + :: List.map (fn (x, i, _) => FoundExp (x, (Elab.CRel i, loc))) cs + | (Elab.SgiStr (_, name, _, sgn), _) => + [FoundStr (name, sgn)] + | (Elab.SgiSgn (name, _, sgn), _) => + [FoundStr (name, sgn)] + | _ => [] + in + List.concat (List.map mapF items) + end + +fun resolvePrefixes + (env: ElabEnv.env) + (prefixes: string list) + (items : foundInEnv list) + : foundInEnv list + = + case prefixes of + [] => items + | first :: rest => + (case List.find (fn item => getNameOfFoundInEnv item = first) items of + NONE => [] + | SOME (FoundStr (name, sgn)) => (case ElabEnv.hnormSgn env sgn of + (Elab.SgnConst sgis, _) => resolvePrefixes env rest (filterSgiItems sgis) + | _ => []) + | SOME (FoundExp (name, c)) => + let + val fields = case ElabOps.reduceCon env c of + (Elab.TRecord (Elab.CRecord (_, fields), l2_), l1_) => + fields + | ( ( Elab.CApp + ( ( (Elab.CApp + ( ( Elab.CModProj (_, _, "sql_table") , l4_) + , ( Elab.CRecord (_, fields) , l3_))) + , l2_) + , _)) + , l1_) => fields + | _ => [] + val items = + List.mapPartial (fn (c1, c2) => case c1 of + (Elab.CName fieldName, _) => SOME (FoundExp (fieldName, c2)) + | _ => NONE) fields + in + resolvePrefixes env rest items + end + | SOME (FoundCon (_, _)) => []) + + +fun findStringInEnv' (env: ElabEnv.env) (preferCon: bool) (str: string): (string (* prefix *) * foundInEnv option) = + let + val splitted = List.map Substring.string (Substring.fields (fn c => c = #".") (Substring.full str)) + val afterResolve = resolvePrefixes env (List.take (splitted, List.length splitted - 1)) + ( List.map (fn (name, (_, sgn)) => FoundStr (name, sgn)) (ElabEnv.dumpStrs env) + @ List.map FoundCon (ElabEnv.dumpCs env) + @ List.map FoundExp (ElabEnv.dumpEs env)) + val query = List.last splitted + val prefix = String.extract (str, 0, SOME (String.size str - String.size query)) + in + (prefix, List.find (fn i => getNameOfFoundInEnv i = query) afterResolve) + end + +fun matchStringInEnv' (env: ElabEnv.env) (str: string): (string (* prefix *) * foundInEnv list) = + let + val splitted = List.map Substring.string (Substring.fields (fn c => c = #".") (Substring.full str)) + val afterResolve = resolvePrefixes env (List.take (splitted, List.length splitted - 1)) + ( List.map (fn (name, (_, sgn)) => FoundStr (name, sgn)) (ElabEnv.dumpStrs env) + @ List.map FoundCon (ElabEnv.dumpCs env) + @ List.map FoundExp (ElabEnv.dumpEs env)) + val query = List.last splitted + val prefix = String.extract (str, 0, SOME (String.size str - String.size query)) + in + (prefix, List.filter (fn i => String.isPrefix query (getNameOfFoundInEnv i)) afterResolve) + end + +fun getDesc item = + case item of + Kind (_, s) => "Kind " ^ ErrorMsg.spanToString s + | Con (_, s) => "Con " ^ ErrorMsg.spanToString s + | Exp (_, s) => "Exp " ^ ErrorMsg.spanToString s + | Sgn_item (_, s) => "Sgn_item " ^ ErrorMsg.spanToString s + | Sgn (_, s) => "Sgn " ^ ErrorMsg.spanToString s + | Str (_, s) => "Str " ^ ErrorMsg.spanToString s + | Decl (_, s) => "Decl " ^ ErrorMsg.spanToString s + +fun matchStringInEnv env str fileName pos query: (ElabEnv.env * string (* prefix *) * foundInEnv list) = + let + val {item = _, env} = findSmallestSpan env str fileName pos + val (prefix, matches) = matchStringInEnv' env query + in + (env, prefix, matches) + end + +fun findStringInEnv env str fileName pos (query: string): (ElabEnv.env * string (* prefix *) * foundInEnv option) = + let + val {item, env} = findSmallestSpan env str fileName pos + val env = case item of + Exp (L.ECase _, _) => #env (findFirstExpAfter env str fileName pos) + | Exp (L.ELet _, _) => #env (findFirstExpAfter env str fileName pos) + | Exp (L.EAbs _, _) => #env (findFirstExpAfter env str fileName pos) + | Exp e => env + | Con _ => #env (findFirstExpAfter env str fileName pos) + | _ => #env (findFirstExpAfter env str fileName pos) + val preferCon = case item of Con _ => true + | _ => false + val (prefix, found) = findStringInEnv' env preferCon query in - result + (env, prefix, found) end end diff --git a/src/lsp.sml b/src/lsp.sml index 856b7ab8..e29589c2 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -1,7 +1,8 @@ -structure C = Compiler - structure Lsp :> LSP = struct +structure C = Compiler +structure P = Print + val debug = LspSpec.debug structure SK = struct @@ -317,6 +318,35 @@ fun ppToString (pp: Print.PD.pp_desc) (width: int): string = res end +fun getStringAtCursor + (stopAtCursor: bool) + (text: string) + (pos: LspSpec.position) + : string + = + let + val line = List.nth (Substring.fields (fn c => c = #"\n") (Substring.full text), #line pos) + val chars = [ (* #".", *) #"(", #")", #"{", #"}", #"[", #"]", #"<", #">", #"-", #"=", #":" + , #" ", #"\n", #"#", #",", #"*", #"\"", #"|", #"&", #"$", #"^", #"+", #";"] + val lineUntilCursor = Substring.slice (line, 0, SOME (#character pos)) + val beforeCursor = Substring.string (Substring.taker (fn c => not (List.exists (fn c' => c = c') chars)) lineUntilCursor) + val afterCursor = if stopAtCursor + then "" + else let + val lineAfterCursor = Substring.slice (line, #character pos, NONE) + in + Substring.string (Substring.takel (fn c => not (List.exists (fn c' => c = c') (#"." :: chars))) lineAfterCursor) + end + in + beforeCursor ^ afterCursor + end + +fun formatTypeBox (a: P.PD.pp_desc, b: P.PD.pp_desc) = + P.PD.hvBox (P.PD.PPS.Rel 0, [a, + P.PD.string ": ", + P.PD.break {nsp = 0, offset = 2}, + b]) + fun handleHover (state: state) (p: LspSpec.hoverReq): LspSpec.hoverResp LspSpec.result = let val fileName = #path (#uri (#textDocument p)) @@ -326,177 +356,27 @@ fun handleHover (state: state) (p: LspSpec.hoverReq): LspSpec.hoverResp LspSpec. NONE => LspSpec.Success NONE | SOME s => let + val searchString = getStringAtCursor false (#text s) (#position p) val env = #envBeforeThisModule s val decls = #decls s val loc = #position p - val result = GetInfo.getInfo env (Elab.StrConst decls) fileName { line = #line loc + 1 - , character = #character loc + 1} + val (env, prefix, found) = GetInfo.findStringInEnv env (Elab.StrConst decls) fileName { line = #line loc + 1 + , char = #character loc + 1} searchString in - case #smallestgoodpart result of + case found of NONE => LspSpec.Success NONE - | SOME {desc = desc, ...} => - LspSpec.Success (SOME {contents = ppToString desc 50}) + | SOME f => + let + val desc = case f of + GetInfo.FoundStr (x, (_, sgn)) => formatTypeBox (P.PD.string (prefix ^ x), P.PD.string "module") + | GetInfo.FoundCon (x, kind) => formatTypeBox (P.PD.string (prefix ^ x), ElabPrint.p_kind env kind) + | GetInfo.FoundExp (x, con) => formatTypeBox (P.PD.string (prefix ^ x), ElabPrint.p_con env con) + in + LspSpec.Success (SOME {contents = ppToString desc 50}) + end 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) 200 - } - 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) 200 - }] - else [] - | (Elab.SgiCon (name, _, _, con), _) => - if String.isPrefix searchStr name - then [{ label = prefix ^ name - , kind = LspSpec.Value - , detail = ppToString (ElabPrint.p_con env con) 200 - }] - 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 x k) env xs - val typeVarsString = List.foldl (fn (x, acc) => acc ^ " " ^ x) "" 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 => dtName ^ typeVarsString - | SOME con => ppToString (ElabPrint.p_con env con) 200 ^ " -> " ^ dtName ^ typeVarsString - } - 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) 200 - }] - else [] - | _ => [] - in - List.concat (List.map mapF items) - end - -(* TODO TOCHECK look at con's to specify "kind" more accurately *) -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 - let - val matchingEs = ElabEnv.matchEByPrefix env str (* function params, let bindings and top-level bindings. Should we discern between Rel and Named? *) - val expressionCompletions = List.map (fn (name,con) => - { label = name - , kind = LspSpec.Value - , detail = ppToString (ElabPrint.p_con env con) 200 - }) matchingEs - val matchingStrs = ElabEnv.matchStrByPrefix env str - val structureCompletions = List.map (fn (name,(_,sgn)) => - { label = name - , kind = LspSpec.Module - , detail = "" - }) matchingStrs - val matchingCons = ElabEnv.matchCByPrefix env str - val conCompletions = List.map (fn (name,kind) => - { label = name - , kind = LspSpec.Constructor (* TODO probably wrong... *) - , detail = ppToString (ElabPrint.p_kind env kind) 200 - }) matchingCons - in - expressionCompletions @ structureCompletions @ conCompletions - end - | (r :: str :: []) => - if Char.isUpper (Substring.sub (r, 0)) - then - (* Completing STRUCTURE *) - let - (* TODO PERF SMALL: 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 - (* Completing RECORD *) - (* TODO TOCHECK is it correct to first try RelE and then NamedE? *) - let - (* TODO PERF SMALL: first match and then equal is not perfect *) - val foundEs = ElabEnv.matchEByPrefix env (Substring.string r) - val filteredEs = List.filter (fn (name,_) => name = Substring.string r) foundEs - val reduced = List.map (fn (name, c) => - (name, ElabOps.reduceCon env c) - handle ex => (name, (Elab.CUnit, ErrorMsg.dummySpan))) - filteredEs - in - case reduced of - [] => [] - | (name, (Elab.TRecord (Elab.CRecord (_, fields), l2_), l1_)) :: _ => - getCompletionsFromFields env (name ^ ".") (Substring.string str) fields - | (name, - ( ( Elab.CApp - ( ( (Elab.CApp - ( ( Elab.CModProj (_, _, "sql_table") - , l4_) - , ( Elab.CRecord (_, fields) - , l3_))) - , l2_) - , _)) - , l1_)) :: _ => - getCompletionsFromFields env (name ^ ".") (Substring.string str) fields - | _ => [] - end - | _ => - (* TODO NOTIMPLEMENTED submodules / nested records *) - [] - end - (* TODO IDEA 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 @@ -508,19 +388,20 @@ fun handleCompletion (state: state) (p: LspSpec.completionReq) = | SOME s => let val pos = #position p - val line = List.nth (Substring.fields (fn c => c = #"\n") (Substring.full (#text s)), #line pos) - val chars = [ (* #".", *) #"(", #")", #"{", #"}", #"[", #"]", #"<", #">", #"-", #"=", #":" - , #" ", #"\n", #"#", #",", #"*", #"\"", #"|", #"&", #"$", #"^", #"+", #";"] - val lineUntilPos = Substring.slice (line, 0, SOME (#character pos)) - val searchStr = Substring.string (Substring.taker (fn c => not (List.exists (fn c' => c = c') chars)) lineUntilPos) + val searchStr = getStringAtCursor true (#text s) pos 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) + val (env, prefix, foundItems) = GetInfo.matchStringInEnv env (Elab.StrConst decls) fileName { line = #line pos + 1, char = #character pos + 1} searchStr + val completions = List.map + (fn f => case f of + GetInfo.FoundStr (x, _) => {label = prefix ^ x, kind = LspSpec.Module, detail = ""} + | GetInfo.FoundCon (x, k) => {label = prefix ^ x, kind = LspSpec.Constructor, detail = ppToString (ElabPrint.p_kind env k) 200} + | GetInfo.FoundExp (x, c) => {label = prefix ^ x, kind = LspSpec.Value, detail = ppToString (ElabPrint.p_con env c) 200} + ) + foundItems in LspSpec.Success { isIncomplete = false - , items = findMatchingStringInEnv envOfSmallest searchStr} + , items = completions } end end -- cgit v1.2.3 From 0e6ae5392121aa2163199292963f0f98776b6790 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Sat, 11 Jan 2020 21:51:21 +0100 Subject: Fixed review changes: Better foundInEnv naming, correct interpretation of SgiSgn, fix uniq --- src/getinfo.sig | 4 ++-- src/getinfo.sml | 35 +++++++++++++++++------------------ src/lsp.sml | 14 +++++++------- 3 files changed, 26 insertions(+), 27 deletions(-) (limited to 'src/lsp.sml') diff --git a/src/getinfo.sig b/src/getinfo.sig index 663a9a81..63850ef2 100644 --- a/src/getinfo.sig +++ b/src/getinfo.sig @@ -28,8 +28,8 @@ signature GET_INFO = sig datatype foundInEnv = FoundStr of (string * Elab.sgn) - | FoundCon of (string * Elab.kind) - | FoundExp of (string * Elab.con) + | FoundKind of (string * Elab.kind) + | FoundCon of (string * Elab.con) val findStringInEnv: ElabEnv.env -> diff --git a/src/getinfo.sml b/src/getinfo.sml index 760a4d90..6adfbdcf 100644 --- a/src/getinfo.sml +++ b/src/getinfo.sml @@ -163,32 +163,31 @@ fun findFirstExpAfter env str fileName {line = line, char = char} = datatype foundInEnv = FoundStr of (string * Elab.sgn) - | FoundCon of (string * Elab.kind) - | FoundExp of (string * Elab.con) + | FoundKind of (string * Elab.kind) + | FoundCon of (string * Elab.con) fun getNameOfFoundInEnv (f: foundInEnv) = case f of FoundStr (x, _) => x + | FoundKind (x, _) => x | FoundCon (x, _) => x - | FoundExp (x, _) => x fun filterSgiItems (items: Elab.sgn_item list) : foundInEnv list = let fun mapF item = case item of - (Elab.SgiVal (name, _, c), _) => [FoundExp (name, c)] - | (Elab.SgiCon (name, _, k, _), _) => [FoundCon (name, k)] + (Elab.SgiVal (name, _, c), _) => [FoundCon (name, c)] + | (Elab.SgiCon (name, _, k, _), _) => [FoundKind (name, k)] | (Elab.SgiDatatype ds, loc) => List.concat (List.map (fn (dtx, i, _, cs) => - FoundExp (dtx, (Elab.CNamed i, loc)) - :: List.map (fn (x, i, _) => FoundExp (x, (Elab.CRel i, loc))) cs) ds) + FoundCon (dtx, (Elab.CNamed i, loc)) + :: List.map (fn (x, i, _) => FoundCon (x, (Elab.CRel i, loc))) cs) ds) | (Elab.SgiDatatypeImp (x, i, _, _, _, _, cs), loc) => - FoundExp (x, (Elab.CNamed i, loc)) - :: List.map (fn (x, i, _) => FoundExp (x, (Elab.CRel i, loc))) cs + FoundCon (x, (Elab.CNamed i, loc)) + :: List.map (fn (x, i, _) => FoundCon (x, (Elab.CRel i, loc))) cs | (Elab.SgiStr (_, name, _, sgn), _) => [FoundStr (name, sgn)] - | (Elab.SgiSgn (name, _, sgn), _) => - [FoundStr (name, sgn)] + | (Elab.SgiSgn (name, _, sgn), _) => [] | _ => [] in List.concat (List.map mapF items) @@ -208,7 +207,7 @@ fun resolvePrefixes | SOME (FoundStr (name, sgn)) => (case ElabEnv.hnormSgn env sgn of (Elab.SgnConst sgis, _) => resolvePrefixes env rest (filterSgiItems sgis) | _ => []) - | SOME (FoundExp (name, c)) => + | SOME (FoundCon (name, c)) => let val fields = case ElabOps.reduceCon env c of (Elab.TRecord (Elab.CRecord (_, fields), l2_), l1_) => @@ -223,12 +222,12 @@ fun resolvePrefixes | _ => [] val items = List.mapPartial (fn (c1, c2) => case c1 of - (Elab.CName fieldName, _) => SOME (FoundExp (fieldName, c2)) + (Elab.CName fieldName, _) => SOME (FoundCon (fieldName, c2)) | _ => NONE) fields in resolvePrefixes env rest items end - | SOME (FoundCon (_, _)) => []) + | SOME (FoundKind (_, _)) => []) fun findStringInEnv' (env: ElabEnv.env) (preferCon: bool) (str: string): (string (* prefix *) * foundInEnv option) = @@ -236,8 +235,8 @@ fun findStringInEnv' (env: ElabEnv.env) (preferCon: bool) (str: string): (string val splitted = List.map Substring.string (Substring.fields (fn c => c = #".") (Substring.full str)) val afterResolve = resolvePrefixes env (List.take (splitted, List.length splitted - 1)) ( List.map (fn (name, (_, sgn)) => FoundStr (name, sgn)) (ElabEnv.dumpStrs env) - @ List.map FoundCon (ElabEnv.dumpCs env) - @ List.map FoundExp (ElabEnv.dumpEs env)) + @ List.map FoundKind (ElabEnv.dumpCs env) + @ List.map FoundCon (ElabEnv.dumpEs env)) val query = List.last splitted val prefix = String.extract (str, 0, SOME (String.size str - String.size query)) in @@ -249,8 +248,8 @@ fun matchStringInEnv' (env: ElabEnv.env) (str: string): (string (* prefix *) * f val splitted = List.map Substring.string (Substring.fields (fn c => c = #".") (Substring.full str)) val afterResolve = resolvePrefixes env (List.take (splitted, List.length splitted - 1)) ( List.map (fn (name, (_, sgn)) => FoundStr (name, sgn)) (ElabEnv.dumpStrs env) - @ List.map FoundCon (ElabEnv.dumpCs env) - @ List.map FoundExp (ElabEnv.dumpEs env)) + @ List.map FoundKind (ElabEnv.dumpCs env) + @ List.map FoundCon (ElabEnv.dumpEs env)) val query = List.last splitted val prefix = String.extract (str, 0, SOME (String.size str - String.size query)) in diff --git a/src/lsp.sml b/src/lsp.sml index e29589c2..c99a6f2e 100644 --- a/src/lsp.sml +++ b/src/lsp.sml @@ -257,10 +257,10 @@ fun elabFile (state: state) (fileName: string): ({ decls: Elab.decl list, envBef end end -fun uniq (comp: 'b -> 'b -> bool) (bs: 'b list) = +fun uniq (eq: 'b -> 'b -> bool) (bs: 'b list) = case bs of [] => [] - | (l as b :: bs') => b :: uniq comp (List.filter (comp b) bs') + | (l as b :: bs') => b :: uniq eq (List.filter (fn a => not (eq a b)) bs') fun elabFileAndSendDiags (state: state) (toclient: LspSpec.toclient) (documentUri: LspSpec.documentUri): unit = let @@ -326,7 +326,7 @@ fun getStringAtCursor = let val line = List.nth (Substring.fields (fn c => c = #"\n") (Substring.full text), #line pos) - val chars = [ (* #".", *) #"(", #")", #"{", #"}", #"[", #"]", #"<", #">", #"-", #"=", #":" + val chars = [ (* #".", *) #"(", #")", #"{", #"}", #"[", #"]", #"<", #">", #"-", #"=", #":", #"@" , #" ", #"\n", #"#", #",", #"*", #"\"", #"|", #"&", #"$", #"^", #"+", #";"] val lineUntilCursor = Substring.slice (line, 0, SOME (#character pos)) val beforeCursor = Substring.string (Substring.taker (fn c => not (List.exists (fn c' => c = c') chars)) lineUntilCursor) @@ -369,8 +369,8 @@ fun handleHover (state: state) (p: LspSpec.hoverReq): LspSpec.hoverResp LspSpec. let val desc = case f of GetInfo.FoundStr (x, (_, sgn)) => formatTypeBox (P.PD.string (prefix ^ x), P.PD.string "module") - | GetInfo.FoundCon (x, kind) => formatTypeBox (P.PD.string (prefix ^ x), ElabPrint.p_kind env kind) - | GetInfo.FoundExp (x, con) => formatTypeBox (P.PD.string (prefix ^ x), ElabPrint.p_con env con) + | GetInfo.FoundKind (x, kind) => formatTypeBox (P.PD.string (prefix ^ x), ElabPrint.p_kind env kind) + | GetInfo.FoundCon (x, con) => formatTypeBox (P.PD.string (prefix ^ x), ElabPrint.p_con env con) in LspSpec.Success (SOME {contents = ppToString desc 50}) end @@ -395,8 +395,8 @@ fun handleCompletion (state: state) (p: LspSpec.completionReq) = val completions = List.map (fn f => case f of GetInfo.FoundStr (x, _) => {label = prefix ^ x, kind = LspSpec.Module, detail = ""} - | GetInfo.FoundCon (x, k) => {label = prefix ^ x, kind = LspSpec.Constructor, detail = ppToString (ElabPrint.p_kind env k) 200} - | GetInfo.FoundExp (x, c) => {label = prefix ^ x, kind = LspSpec.Value, detail = ppToString (ElabPrint.p_con env c) 200} + | GetInfo.FoundKind (x, k) => {label = prefix ^ x, kind = LspSpec.Constructor, detail = ppToString (ElabPrint.p_kind env k) 200} + | GetInfo.FoundCon (x, c) => {label = prefix ^ x, kind = LspSpec.Value, detail = ppToString (ElabPrint.p_con env c) 200} ) foundItems in -- cgit v1.2.3