Experimental ReScript Language Server in OCaml

dune

@@ -1 +1 @@
-(dirs compiler tests analysis tools)
+(dirs compiler tests analysis tools lsp)

dune-project

@@ -69,3 +69,18 @@
    (= 1.8.0))
   analysis
   (odoc :with-doc)))
+
+(package
+ (name rescript-language-server)
+ (synopsis "ReScript LSP")
+ (depends
+ (ocaml
+  (>= 4.10))
+ (lsp
+  (>= 1.22.0))
+ (eio
+  (>= 1.3))
+ (eio_main
+  (>= 1.3))
+ analysis
+ dune))

lsp/bin/dune

@@ -0,0 +1,5 @@
+(executable
+ (name main)
+ (package rescript-language-server)
+ (public_name rescript-language-server)
+ (libraries rescript_language_server))

lsp/bin/main.ml

@@ -0,0 +1 @@
+let () = Rescript_language_server.main ()

lsp/src/diagnostics.ml

@@ -0,0 +1,5 @@
+module UriMap = Map.Make (Lsp.Uri)
+
+type t = Lsp.Types.Diagnostic.t list UriMap.t
+
+let create () = UriMap.empty

lsp/src/document_store.ml

@@ -0,0 +1,30 @@
+(* module UriMap = Map.Make (Lsp.Uri) *)
+
+type document = {text: string; version: int}
+
+type t = {documents: (Lsp.Uri.t, document) Hashtbl.t}
+
+let create () = {documents = Hashtbl.create 25}
+
+let open_document t ~uri ~text ~version =
+  Hashtbl.add t.documents uri {text; version};
+  t
+
+let update_document t ~uri ~text ~version =
+  (match Hashtbl.find_opt t.documents uri with
+  | None ->
+    raise
+      (Failure (Printf.sprintf "Document not found: %s" (Lsp.Uri.to_string uri)))
+  | Some _ -> Hashtbl.replace t.documents uri {text; version});
+  t
+
+let remove_document t ~uri =
+  Hashtbl.remove t.documents uri;
+  t
+
+let get_document t ~uri =
+  match Hashtbl.find_opt t.documents uri with
+  | Some doc -> doc
+  | None ->
+    raise
+      (Failure (Printf.sprintf "Document not found: %s" (Lsp.Uri.to_string uri)))

lsp/src/dune

@@ -0,0 +1,5 @@
+(library
+ (name rescript_language_server)
+ (libraries lsp eio eio_main analysis)
+ (flags
+  (-w "-9")))

lsp/src/hover.ml

@@ -0,0 +1,30 @@
+open Lsp.Types
+
+let create ~(position : Position.t) ~(uri : DocumentUri.t)
+    (server : State.t Server.t) =
+  let path = DocumentUri.to_path uri in
+  let pos = (position.line, position.character) in
+
+  (* NOTE: Should be a config *)
+  let supportsMarkdownLinks = true in
+
+  let result =
+    let open Analysis in
+    let source = (Document_store.get_document ~uri server.state.store).text in
+    let debug = false in
+
+    let kindFile = Files.classifySourceFile path in
+    let full = Cmt.loadFullCmtFromPath ~path in
+
+    Commands.hover ~source ~kindFile ~pos ~debug ~supportsMarkdownLinks ~full
+  in
+
+  match result with
+  | None -> None
+  | Some value ->
+    Some
+      (Hover.create
+         ~contents:
+           (`MarkupContent
+              (MarkupContent.create ~kind:MarkupKind.Markdown ~value))
+         ())

lsp/src/rescript_language_server.ml

@@ -0,0 +1,79 @@
+let initialization (client_capabilities : Lsp.Types.ClientCapabilities.t) =
+  let open Lsp.Types in
+  let textDocumentSync =
+    `TextDocumentSyncOptions
+      (TextDocumentSyncOptions.create ~openClose:true
+         ~change:TextDocumentSyncKind.Full ~willSave:false
+         ~save:(`SaveOptions (SaveOptions.create ~includeText:false ()))
+         ~willSaveWaitUntil:false ())
+  in
+  let capabilities =
+    ServerCapabilities.create ~textDocumentSync ~hoverProvider:(`Bool true) ()
+  in
+  let serverInfo =
+    let version = "2.0.0-aplha.1" in
+    InitializeResult.create_serverInfo ~name:"rescript-language-server" ~version
+      ()
+  in
+  InitializeResult.create ~capabilities ~serverInfo ()
+
+let on_initialize (params : Lsp.Types.InitializeParams.t) (state : State.t) =
+  (* TODO:
+    * Find root project (rescript.json, package.json) using InitializeParams.workspaceFolders and save in State.t
+      * See https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#initializeParams
+      * If not found rescript.json kill the server?
+    * Save initializationOptions in State.t
+      * This options are: askToStartBuild, codeLens.enable, inlayHints.enable, etc..
+    * Collect compiler diagnostics (syntax and type)?
+  *)
+  let diagnostics = Diagnostics.create () in
+  let initialization_info = initialization params.capabilities in
+  let state = State.initialize state ~params ~diagnostics in
+  (initialization_info, state)
+
+let on_request (Lsp.Client_request.E request) (server : State.t Server.t) =
+  let state = Server.state server in
+  let ok value = Ok (Lsp.Client_request.yojson_of_result request value) in
+  match request with
+  | Lsp.Client_request.Initialize params ->
+    let initialization_info, state = on_initialize params state in
+    (ok initialization_info, state)
+  | Shutdown -> (ok (), state)
+  | TextDocumentHover {position; textDocument = {uri}} ->
+    (ok (Hover.create ~position ~uri server), state)
+  | _ ->
+    let err =
+      Jsonrpc.Response.Error.make
+        ~code:Jsonrpc.Response.Error.Code.MethodNotFound
+        ~message:"Request method not supported" ()
+    in
+    (Error err, state)
+
+let on_notification notification (server : State.t Server.t) =
+  let state = Server.state server in
+
+  match notification with
+  | Lsp.Client_notification.TextDocumentDidOpen
+      {textDocument = {uri; text; version; _}} ->
+    let store = Document_store.open_document ~uri ~text ~version state.store in
+    {state with store}
+  (* | TextDocumentDidChange {textDocument = {uri; version; _}; contentChanges}
+    -> (
+    match List.rev contentChanges with
+    | {text; _} :: _ -> state
+    | [] -> state) *)
+  | TextDocumentDidClose {textDocument = {uri; _}} ->
+    (* TODO:
+     * remove state diagnostics
+     * send updated diagnostics?
+     *)
+    let store = Document_store.remove_document ~uri state.store in
+    {state with store}
+  | Exit -> state
+  | _ -> state
+
+let main () =
+  Eio_main.run (fun env ->
+      let state = State.create ~store:(Document_store.create ()) in
+      Server.listen ~input:env#stdin ~output:env#stdout ~on_request
+        ~on_notification ~state ~env)

lsp/src/server.ml

@@ -0,0 +1,159 @@
+module Io : sig
+  type 'a t
+
+  val return : 'a -> 'a t
+  val raise : exn -> 'a t
+  val await : 'a t -> 'a
+  val async : (sw:Eio.Switch.t -> ('a, exn) result) -> 'a t
+
+  module O : sig
+    val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
+    val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t
+  end
+end = struct
+  type 'a t = sw:Eio.Switch.t -> ('a, exn) result Eio.Promise.t
+
+  let await t = Eio.Switch.run @@ fun sw -> Eio.Promise.await_exn (t ~sw)
+  let return value ~sw:_ = Eio.Promise.create_resolved (Ok value)
+  let error desc ~sw:_ = Eio.Promise.create_resolved (Error desc)
+
+  let async f ~sw =
+    let promise, resolver = Eio.Promise.create () in
+    ( Eio.Fiber.fork ~sw @@ fun () ->
+      try
+        let result = f ~sw in
+        Eio.Promise.resolve resolver result
+      with exn -> Eio.Promise.resolve resolver @@ Error exn );
+    promise
+
+  let bind t f =
+    async @@ fun ~sw ->
+    match Eio.Promise.await (t ~sw) with
+    | Ok value -> Eio.Promise.await @@ f value ~sw
+    | Error desc -> Error desc
+
+  let raise = error
+
+  module O = struct
+    let ( let+ ) x f = bind x @@ fun value -> return @@ f value
+    let ( let* ) = bind
+  end
+end
+
+module Chan : sig
+  type input
+  type output
+
+  val of_source : [> Eio__Flow.source_ty] Eio.Resource.t -> input
+  val with_sink : [> Eio__Flow.sink_ty] Eio.Resource.t -> (output -> 'a) -> 'a
+
+  val read_line : input -> string option Io.t
+  val read_exactly : input -> int -> string option Io.t
+  val write : output -> string list -> unit Io.t
+end = struct
+  type input = {mutex: Eio.Mutex.t; buf: Eio.Buf_read.t}
+  type output = {mutex: Eio.Mutex.t; buf: Eio.Buf_write.t}
+
+  let initial_size = 1024
+  let max_size = 1024 * 1024
+
+  let of_source source : input =
+    let mutex = Eio.Mutex.create () in
+    let buf = Eio.Buf_read.of_flow ~initial_size ~max_size source in
+    {mutex; buf}
+
+  let with_sink sink f =
+    let mutex = Eio.Mutex.create () in
+    Eio.Buf_write.with_flow ~initial_size sink @@ fun buf -> f {mutex; buf}
+
+  let read_line (input : input) =
+    Io.async @@ fun ~sw:_ ->
+    Eio.Mutex.use_rw ~protect:true input.mutex @@ fun () ->
+    if Eio.Buf_read.eof_seen input.buf then Ok None
+    else
+      match Eio.Buf_read.line input.buf with
+      | line -> Ok (Some line)
+      | exception End_of_file -> Ok None
+
+  let read_exactly (input : input) size =
+    Io.async @@ fun ~sw:_ ->
+    Eio.Mutex.use_rw ~protect:true input.mutex @@ fun () ->
+    if Eio.Buf_read.eof_seen input.buf then Ok None
+    else
+      match Eio.Buf_read.take size input.buf with
+      | data -> Ok (Some data)
+      | exception End_of_file -> Ok None
+
+  let write (output : output) (str : string list) =
+    Io.async @@ fun ~sw:_ ->
+    Eio.Mutex.use_rw ~protect:true output.mutex @@ fun () ->
+    Ok (List.iter (Eio.Buf_write.string output.buf) str)
+end
+
+module Lsp_Io = Lsp.Io.Make (Io) (Chan)
+
+let notification_of_jsonrpc notification =
+  match Lsp.Client_notification.of_jsonrpc notification with
+  | Ok notification -> notification
+  | Error error -> raise (Lsp.Io.Error error)
+
+type 'a t = {channel: Chan.output; env: Eio_unix.Stdenv.base; state: 'a}
+
+let state t = t.state
+
+let respond server response =
+  Io.await @@ Lsp_Io.write server.channel @@ Response response
+
+let notification server notification =
+  let notification = Lsp.Server_notification.to_jsonrpc notification in
+  Io.await @@ Lsp_Io.write server.channel @@ Notification notification
+
+let log_message_notification ?(kind = Lsp.Types.MessageType.Debug) server
+    message =
+  notification server
+    (Lsp.Server_notification.LogMessage
+       (Lsp.Types.LogMessageParams.create ~type_:kind ~message))
+
+let rec input_loop ~input ~state with_ =
+  match Io.await @@ Lsp_Io.read input with
+  | Some packet ->
+    let state = with_ state packet in
+    input_loop ~input ~state with_
+  | exception exn -> raise (Failure "Server.input_loop")
+  | None -> ()
+
+let listen ~input ~output ~on_request ~on_notification ~state ~env =
+  let handle_request server request =
+    let response, state =
+      match Lsp.Client_request.of_jsonrpc request with
+      | Error message ->
+        let code = Jsonrpc.Response.Error.Code.InvalidParams in
+        let err = Jsonrpc.Response.Error.make ~code ~message () in
+        (Jsonrpc.Response.{id = request.id; result = Error err}, state)
+      | Ok packed ->
+        let result, state = on_request packed server in
+        (Jsonrpc.Response.{id = request.id; result}, state)
+    in
+    respond server response;
+    state
+  in
+  let handle_notification server notification =
+    on_notification (notification_of_jsonrpc notification) server
+  in
+  let input = Chan.of_source input in
+  Chan.with_sink output (fun channel ->
+      let server = {channel; state; env} in
+      input_loop ~input ~state (fun state packet ->
+          match packet with
+          | Notification notification -> handle_notification server notification
+          | Request request -> handle_request server request
+          | Batch_call calls ->
+            List.fold_left
+              (fun state call ->
+                match call with
+                | `Request request -> handle_request server request
+                | `Notification notification ->
+                  handle_notification server notification)
+              state calls
+          | Response _ -> raise (Lsp.Io.Error "unexpected response")
+          | Batch_response _ -> raise (Lsp.Io.Error "unexpected batch response")))

lsp/src/state.ml

@@ -0,0 +1,13 @@
+open Lsp.Types
+
+type status =
+  | Uninitialized
+  | Initialized of {params: InitializeParams.t; diagnostics: Diagnostics.t}
+
+(* TODO: add trace, configuration *)
+type t = {status: status; store: Document_store.t}
+
+let create ~store = {status = Uninitialized; store}
+
+let initialize t ~params ~diagnostics =
+  {t with status = Initialized {params; diagnostics}}

package.json

@@ -106,6 +106,7 @@
     "tests/tests",
     "tests/tools_tests",
     "tests/commonjs_tests",
+    "tests/lsp_tests/**",
     "scripts/res"
   ],
   "packageManager": "yarn@4.12.0",

rescript-language-server.opam

@@ -0,0 +1,31 @@
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+synopsis: "ReScript LSP"
+maintainer: ["Hongbo Zhang <bobzhang1988@gmail.com>" "Cristiano Calcagno"]
+authors: ["Hongbo Zhang <bobzhang1988@gmail.com>"]
+license: "LGPL-3.0-or-later"
+homepage: "https://github.com/rescript-lang/rescript-compiler"
+bug-reports: "https://github.com/rescript-lang/rescript-compiler/issues"
+depends: [
+  "ocaml" {>= "4.10"}
+  "lsp" {>= "1.22.0"}
+  "eio" {>= "1.3"}
+  "eio_main" {>= "1.3"}
+  "analysis"
+  "dune" {>= "3.17"}
+  "odoc" {with-doc}
+]
+build: [
+  ["dune" "subst"] {dev}
+  [
+    "dune"
+    "build"
+    "-p"
+    name
+    "-j"
+    jobs
+    "@install"
+    "@runtest" {with-test}
+    "@doc" {with-doc}
+  ]
+]