Experimental ReScript Language Server in OCaml

analysis/src/CompletionFrontEnd.ml

@@ -1785,9 +1785,10 @@ let completionWithParser1 ~currentFile ~debug ~offset ~path ~posCursor
 
   if Filename.check_suffix path ".res" then (
     let parser =
-      Res_driver.parsing_engine.parse_implementation ~for_printer:false
+      Res_driver.parsing_engine.parse_implementation_from_source
+        ~for_printer:false
     in
-    let {Res_driver.parsetree = str} = parser ~filename:currentFile in
+    let {Res_driver.parsetree = str} = parser ~source:currentFile in
     iterator.structure iterator str |> ignore;
     if blankAfterCursor = Some ' ' || blankAfterCursor = Some '\n' then (
       scope := !lastScopeBeforeCursor;

compiler/syntax/src/res_ast_debugger.ml

@@ -7,6 +7,9 @@ let print_engine =
       print_implementation =
         (fun ~width:_ ~filename:_ ~comments:_ structure ->
           Printast.implementation Format.std_formatter structure);
+      parse_implementation_from_source =
+        (fun ~width:_ ~source:_ ~comments:_ structure ->
+          Printast.implementation Format.std_formatter structure);
       print_interface =
         (fun ~width:_ ~filename:_ ~comments:_ signature ->
           Printast.interface Format.std_formatter signature);
@@ -962,6 +965,9 @@ module SexpAst = struct
         print_implementation =
           (fun ~width:_ ~filename:_ ~comments:_ parsetree ->
             parsetree |> structure |> Sexp.to_string |> print_string);
+        parse_implementation_from_source =
+          (fun ~width:_ ~source:_ ~comments:_ parsetree ->
+            parsetree |> structure |> Sexp.to_string |> print_string);
         print_interface =
           (fun ~width:_ ~filename:_ ~comments:_ parsetree ->
             parsetree |> signature |> Sexp.to_string |> print_string);
@@ -977,6 +983,11 @@ let comments_print_engine =
         let cmt_tbl = CommentTable.make () in
         CommentTable.walk_structure s cmt_tbl comments;
         CommentTable.log cmt_tbl);
+    Res_driver.parse_implementation_from_source =
+      (fun ~width:_ ~source:_ ~comments s ->
+        let cmt_tbl = CommentTable.make () in
+        CommentTable.walk_structure s cmt_tbl comments;
+        CommentTable.log cmt_tbl);
     print_interface =
       (fun ~width:_ ~filename:_ ~comments s ->
         let cmt_tbl = CommentTable.make () in

compiler/syntax/src/res_driver.ml

@@ -14,6 +14,10 @@ type 'diagnostics parsing_engine = {
     for_printer:bool ->
     filename:string ->
     (Parsetree.structure, 'diagnostics) parse_result;
+  parse_implementation_from_source:
+    for_printer:bool ->
+    source:string ->
+    (Parsetree.structure, 'diagnostics) parse_result;
   parse_interface:
     for_printer:bool ->
     filename:string ->
@@ -29,6 +33,12 @@ type print_engine = {
     comments:Res_comment.t list ->
     Parsetree.structure ->
     unit;
+  parse_implementation_from_source:
+    width:int ->
+    source:string ->
+    comments:Res_comment.t list ->
+    Parsetree.structure ->
+    unit;
   print_interface:
     width:int ->
     filename:string ->
@@ -65,6 +75,25 @@ let parsing_engine =
           invalid;
           comments = List.rev engine.comments;
         });
+    parse_implementation_from_source =
+      (fun ~for_printer ~source ->
+        let engine =
+          setup_from_source ~source ~for_printer ~display_filename:"source" ()
+        in
+        let structure = Res_core.parse_implementation engine in
+        let invalid, diagnostics =
+          match engine.diagnostics with
+          | [] as diagnostics -> (false, diagnostics)
+          | _ as diagnostics -> (true, diagnostics)
+        in
+        {
+          filename = engine.scanner.filename;
+          source = engine.scanner.src;
+          parsetree = structure;
+          diagnostics;
+          invalid;
+          comments = List.rev engine.comments;
+        });
     parse_interface =
       (fun ~for_printer ~filename ->
         let engine = setup ~filename ~for_printer () in
@@ -127,6 +156,10 @@ let print_engine =
       (fun ~width ~filename:_ ~comments structure ->
         print_string
           (Res_printer.print_implementation ~width structure ~comments));
+    parse_implementation_from_source =
+      (fun ~width ~source:_ ~comments structure ->
+        print_string
+          (Res_printer.print_implementation ~width structure ~comments));
     print_interface =
       (fun ~width ~filename:_ ~comments signature ->
         print_string (Res_printer.print_interface ~width signature ~comments));

compiler/syntax/src/res_driver.mli

@@ -12,6 +12,10 @@ type 'diagnostics parsing_engine = {
     for_printer:bool ->
     filename:string ->
     (Parsetree.structure, 'diagnostics) parse_result;
+  parse_implementation_from_source:
+    for_printer:bool ->
+    source:string ->
+    (Parsetree.structure, 'diagnostics) parse_result;
   parse_interface:
     for_printer:bool ->
     filename:string ->
@@ -41,6 +45,12 @@ type print_engine = {
     comments:Res_comment.t list ->
     Parsetree.structure ->
     unit;
+  parse_implementation_from_source:
+    width:int ->
+    source:string ->
+    comments:Res_comment.t list ->
+    Parsetree.structure ->
+    unit;
   print_interface:
     width:int ->
     filename:string ->

compiler/syntax/src/res_driver_binary.ml

@@ -6,6 +6,11 @@ let print_engine =
           output_string stdout Config.ast_impl_magic_number;
           output_value stdout filename;
           output_value stdout structure);
+      parse_implementation_from_source =
+        (fun ~width:_ ~source:_ ~comments:_ structure ->
+          output_string stdout Config.ast_impl_magic_number;
+          output_value stdout "source";
+          output_value stdout structure);
       print_interface =
         (fun ~width:_ ~filename ~comments:_ signature ->
           output_string stdout Config.ast_intf_magic_number;

compiler/syntax/src/res_driver_ml_printer.ml

@@ -4,6 +4,9 @@ let print_engine =
       print_implementation =
         (fun ~width:_ ~filename:_ ~comments:_ structure ->
           Pprintast.structure Format.std_formatter structure);
+      parse_implementation_from_source =
+        (fun ~width:_ ~source:_ ~comments:_ structure ->
+          Pprintast.structure Format.std_formatter structure);
       print_interface =
         (fun ~width:_ ~filename:_ ~comments:_ signature ->
           Pprintast.signature Format.std_formatter signature);

compiler/syntax/src/res_token_debugger.ml

@@ -142,6 +142,8 @@ let token_print_engine =
   {
     Res_driver.print_implementation =
       (fun ~width:_ ~filename ~comments:_ _ -> dump_tokens filename);
+    Res_driver.parse_implementation_from_source =
+      (fun ~width:_ ~source:filename ~comments:_ _ -> dump_tokens filename);
     print_interface =
       (fun ~width:_ ~filename ~comments:_ _ -> dump_tokens filename);
   }

dune

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

dune-project

@@ -19,7 +19,8 @@
  (synopsis "ReScript compiler")
  (depends
   (ocaml
-   (>= 5.0.0))))
+   (>= 5.0.0))
+  (ocaml-lsp-server (and (>= 1.26.0) :with-test-setup))))
 
 (package
  (name analysis)
@@ -43,3 +44,18 @@
    (= 1.8.0))
   analysis
   dune))
+
+(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,136 @@
+open Lsp.Types
+
+let getCompletions ~debug ~path ~pos ~currentFile ~forHover =
+  let textOpt = Some currentFile in
+  match textOpt with
+  | None | Some "" -> None
+  | Some text -> (
+    match
+      Analysis.CompletionFrontEnd.completionWithParser ~debug ~path
+        ~posCursor:pos ~currentFile ~text
+    with
+    | None -> None
+    | Some (completable, scope) -> (
+      (* uncomment when debugging *)
+      if false then (
+        Printf.printf "\nScope from frontend:\n";
+        List.iter
+          (fun item ->
+            Printf.printf "%s\n"
+              (Analysis.SharedTypes.ScopeTypes.item_to_string item))
+          scope;
+        print_newline ());
+      (* Only perform expensive ast operations if there are completables *)
+      match Analysis.Cmt.loadFullCmtFromPath ~path with
+      | None -> None
+      | Some full ->
+        let env = Analysis.SharedTypes.QueryEnv.fromFile full.file in
+        let completables =
+          completable
+          |> Analysis.CompletionBackEnd.processCompletable ~debug ~full ~pos
+               ~scope ~env ~forHover
+        in
+        Some (completables, full, scope)))
+
+(* Leverages autocomplete functionality to produce a hover for a position. This
+   makes it (most often) work with unsaved content. *)
+let getHoverViaCompletions ~debug ~path ~pos ~currentFile ~forHover
+    ~supportsMarkdownLinks =
+  match getCompletions ~debug ~path ~pos ~currentFile ~forHover with
+  | None -> None
+  | Some (completions, ({file; package} as full), scope) -> (
+    let rawOpens = Analysis.Scope.getRawOpens scope in
+    match completions with
+    | {kind = Label typString; docstring} :: _ ->
+      let parts =
+        docstring
+        @ if typString = "" then [] else [Analysis.Markdown.codeBlock typString]
+      in
+
+      Some (String.concat "\n\n" parts)
+    | {kind = Field _; env; docstring} :: _ -> (
+      let opens =
+        Analysis.CompletionBackEnd.getOpens ~debug ~rawOpens ~package ~env
+      in
+      match
+        Analysis.CompletionBackEnd.completionsGetTypeEnv2 ~debug ~full ~rawOpens
+          ~opens ~pos completions
+      with
+      | Some (typ, _env) ->
+        let typeString =
+          Analysis.Hover.hoverWithExpandedTypes ~file ~package ~docstring
+            ~supportsMarkdownLinks typ
+        in
+        Some typeString
+      | None -> None)
+    | {env} :: _ -> (
+      let opens =
+        Analysis.CompletionBackEnd.getOpens ~debug ~rawOpens ~package ~env
+      in
+      match
+        Analysis.CompletionBackEnd.completionsGetTypeEnv2 ~debug ~full ~rawOpens
+          ~opens ~pos completions
+      with
+      | Some (typ, _env) ->
+        let typeString =
+          Analysis.Hover.hoverWithExpandedTypes ~file ~package
+            ~supportsMarkdownLinks typ
+        in
+        Some typeString
+      | None -> None)
+    | _ -> None)
+
+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 currentFile =
+    (Document_store.get_document ~uri server.state.store).text
+  in
+  let debug = false in
+
+  let result =
+    match Analysis.Cmt.loadFullCmtFromPath ~path with
+    | None -> None
+    | Some full -> (
+      match Analysis.References.getLocItem ~full ~pos ~debug with
+      | None ->
+        getHoverViaCompletions ~debug ~path ~pos ~currentFile ~forHover:true
+          ~supportsMarkdownLinks:false
+      | Some locItem ->
+        let isModule =
+          match locItem.locType with
+          | LModule _ | TopLevelModule _ -> true
+          | TypeDefinition _ | Typed _ | Constant _ -> false
+        in
+        let uriLocOpt =
+          Analysis.References.definitionForLocItem ~full locItem
+        in
+        let skipZero =
+          match uriLocOpt with
+          | None -> false
+          | Some (_, loc) ->
+            let isInterface = full.file.uri |> Analysis.Uri.isInterface in
+            let posIsZero {Lexing.pos_lnum; pos_bol; pos_cnum} =
+              (not isInterface) && pos_lnum = 1 && pos_cnum - pos_bol = 0
+            in
+            (* Skip if range is all zero, unless it's a module *)
+            (not isModule) && posIsZero loc.loc_start && posIsZero loc.loc_end
+        in
+        if skipZero then None
+        else Analysis.Hover.newHover ~supportsMarkdownLinks ~full locItem)
+  in
+
+  match result with
+  | None -> None
+  | Some value ->
+    Some
+      (Hover.create
+         ~contents:
+           (`MarkupContent
+              (MarkupContent.create ~kind:MarkupKind.Markdown ~value))
+         ())