summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Simon Van Casteren <simonvancasteren@localhost.localdomain>2019-12-13 11:32:02 +0100
committerGravatar Simon Van Casteren <simonvancasteren@localhost.localdomain>2019-12-13 11:46:57 +0100
commitbe644b0be6acd3cdeb957d46e9477ea3e16599ba (patch)
tree40691e62e95309cfacfe6fb2ecb877c85485a305 /src
parentf2ada9d9761c3aa7575571fd93629b79350a1425 (diff)
Moved json and lsp code into seperate modules
Diffstat (limited to 'src')
-rw-r--r--src/fromjson.sig8
-rw-r--r--src/fromjson.sml35
-rw-r--r--src/lsp.sml537
-rw-r--r--src/lspspec.sml447
-rw-r--r--src/sources5
5 files changed, 506 insertions, 526 deletions
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