prepare for 0.10

git-subtree-dir: thirdparty/lsp
git-subtree-split: aae6986391a8519de3da6a7a341f2bd3376e0d2f

.github/workflows/gh-pages.yml

@@ -10,7 +10,8 @@ jobs:
     runs-on: ubuntu-latest
     steps:
       - uses: actions/checkout@main
-
+        with:
+          submodules: 'recursive'
       - uses: ocaml/setup-ocaml@v3
         with:
           ocaml-compiler: '5.2'

.github/workflows/main.yml

@@ -15,6 +15,8 @@ jobs:
     runs-on: ${{ matrix.os }}
     steps:
     - uses: actions/checkout@main
+      with:
+        submodules: 'recursive'
     - uses: ocaml/setup-ocaml@v3
       with:
         ocaml-compiler: ${{ matrix.ocaml-compiler }}
@@ -37,21 +39,17 @@ jobs:
           - 5.1.x
           - 5.2.x
           - 5.3.x
-        lsp-version:
-          - 1.19.0
-          - 1.20.1
-          - 1.22.0
     runs-on: ${{ matrix.os }}
     steps:
     - uses: actions/checkout@main
+      with:
+          submodules: 'recursive'
     - uses: ocaml/setup-ocaml@v3
       with:
         ocaml-compiler: ${{ matrix.ocaml-compiler }}
         dune-cache: true
         allow-prerelease-opam: true
     - run: opam pin -n .
-    - run: opam pin add jsonrpc ${{ matrix.lsp-version }}
-    - run: opam pin add lsp ${{ matrix.lsp-version }}
     - run: opam depext -yt linol linol-lwt linol-eio
     - run: opam install -t . --deps-only
     - run: opam exec -- dune build

.ocamlformat

@@ -1,4 +1,4 @@
-version = 0.24.1
+version = 0.27.0
 profile=conventional
 margin=80
 if-then-else=k-r

CHANGES.md

@@ -1,4 +1,16 @@
 
+# 0.10
+
+- use `git subtree` to vendor lsp+jsonrpc, so that they
+    are not dependencies anymore and do not conflict with
+    other users
+- Add `filter_text_document` to ignore some documents
+
+# 0.9
+
+- Drop redundant dependency on atomic
+- Add support for lsp 1.22
+
 # 0.8
 
 - move to LSP 1.19 and 1.20

Makefile

@@ -13,6 +13,12 @@ clean:
 doc:
 	@dune build @doc
 
+fmt:
+	@dune build @fmt --auto-promote
+
+update-submodules:
+	@git submodule update --init
+
 VERSION=$(shell awk '/^version:/ {print $$2}' linol.opam)
 
 update_next_tag:

dune

@@ -0,0 +1 @@
+(data_only_dirs thirdparty)

dune-project

@@ -8,7 +8,7 @@
 
 (name linol)
 
-(version 0.8)
+(version 0.10)
 
 (license MIT)
 
@@ -28,17 +28,14 @@
   "logs"
   ("trace"
    (>= "0.4"))
-  ("lsp"
-   (and
-    (>= "1.19")
-    (< "1.23")))
-  ("jsonrpc"
-   (and
-    (>= "1.19")
-    (< "1.23")))
   ("ocaml"
    (>= "4.14"))
-  ("odoc" :with-doc)))
+  ("odoc" :with-doc)
+  ; The following dependencies are needed for lsp, which we vendor
+  (uutf
+   (>= 1.0.2))
+  (ppx_yojson_conv_lib
+   (>= "v0.14"))))
 
 (package
  (name linol-lwt)
@@ -53,14 +50,6 @@
    (and
     (>= "5.1")
     (< "6.0")))
-  ("lsp"
-   (and
-    (>= "1.19")
-    (< "1.23")))
-  ("jsonrpc"
-   (and
-    (>= "1.19")
-    (< "1.23")))
   ("odoc" :with-doc)))
 
 (package
@@ -78,12 +67,4 @@
     (>= "1.0")
     (< "2.0")))
   (eio_main :with-test)
-  ("lsp"
-   (and
-    (>= "1.19")
-    (< "1.23")))
-  ("jsonrpc"
-   (and
-    (>= "1.19")
-    (< "1.23")))
   ("odoc" :with-doc)))

example/template-eio/dune

@@ -4,11 +4,4 @@
   ; Deps on linol + Eio backend
   linol
   linol-eio
-  eio_main
-  ; Types from the lsp library are exposed by the linol libs,
-  ; and thus almost guaranteed to be used by code using linol;
-  ; it is thus better to explicitly list lsp as a dep rather
-  ; than rely on its inclusion as a transitive dep of linol
-  ; since it would for instance generate errors if the
-  ; implicit-transitive-deps option of dune is set to false
-  lsp))
+  eio_main))

example/template-eio/main.ml

@@ -15,6 +15,8 @@
      of a document are expected to be able to return.
 *)
 
+module Lsp = Linol.Lsp
+
 type state_after_processing = unit
 
 let process_some_input_file (_file_contents : string) : state_after_processing =

example/template-lwt/dune

@@ -3,11 +3,4 @@
  (libraries
   ; Deps on linol + LWT backend
   linol
-  linol-lwt
-  ; Types from the lsp library are exposed by the linol libs,
-  ; and thus almost guaranteed to be used by code using linol;
-  ; it is thus better to explicitly list lsp as a dep rather
-  ; than rely on its inclusion as a transitive dep of linol
-  ; since it would for instance generate errors if the
-  ; implicit-transitive-deps option of dune is set to false
-  lsp))
+  linol-lwt))

example/template-lwt/main.ml

@@ -15,6 +15,8 @@
      of a document are expected to be able to return.
 *)
 
+module Lsp = Linol.Lsp
+
 type state_after_processing = unit
 
 let process_some_input_file (_file_contents : string) : state_after_processing =

linol-eio.opam

@@ -1,6 +1,6 @@
 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
-version: "0.8"
+version: "0.10"
 synopsis: "LSP server library (with Eio for concurrency)"
 maintainer: ["Simon Cruanes"]
 authors: ["Nick Hu"]
@@ -14,8 +14,6 @@ depends: [
   "base-unix"
   "eio" {>= "1.0" & < "2.0"}
   "eio_main" {with-test}
-  "lsp" {>= "1.19" & < "1.23"}
-  "jsonrpc" {>= "1.19" & < "1.23"}
   "odoc" {with-doc}
 ]
 build: [

linol-lwt.opam

@@ -1,6 +1,6 @@
 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
-version: "0.8"
+version: "0.10"
 synopsis: "LSP server library (with Lwt for concurrency)"
 maintainer: ["Simon Cruanes"]
 authors: ["Simon Cruanes"]
@@ -13,8 +13,6 @@ depends: [
   "linol" {= version}
   "base-unix"
   "lwt" {>= "5.1" & < "6.0"}
-  "lsp" {>= "1.19" & < "1.23"}
-  "jsonrpc" {>= "1.19" & < "1.23"}
   "odoc" {with-doc}
 ]
 build: [

linol.opam

@@ -1,6 +1,6 @@
 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
-version: "0.8"
+version: "0.10"
 synopsis: "LSP server library"
 maintainer: ["Simon Cruanes"]
 authors: ["Simon Cruanes"]
@@ -12,10 +12,10 @@ depends: [
   "yojson" {>= "1.6"}
   "logs"
   "trace" {>= "0.4"}
-  "lsp" {>= "1.19" & < "1.23"}
-  "jsonrpc" {>= "1.19" & < "1.23"}
   "ocaml" {>= "4.14"}
   "odoc" {with-doc}
+  "uutf" {>= "1.0.2"}
+  "ppx_yojson_conv_lib" {>= "v0.14"}
 ]
 build: [
   ["dune" "subst"] {pinned}

src/blocking_IO.ml

@@ -10,11 +10,9 @@ let ( let* ) x f = f x
 let ( and+ ) a b = a, b
 let return x = x
 let failwith = failwith
-
 let fail = Printexc.raise_with_backtrace
-
-let stdin = fun () -> stdin
-let stdout = fun () -> stdout
+let stdin () = stdin
+let stdout () = stdout
 
 let default_spawn f =
   let run () =

src/common_.ml

@@ -1,3 +1,5 @@
+module Lsp = Linol_lsp.Lsp
+module Jsonrpc = Linol_jsonrpc.Jsonrpc
 module Trace = Trace_core
 
 let ( let@ ) = ( @@ )

src/dune

@@ -3,4 +3,10 @@
  (public_name linol)
  (private_modules log)
  (flags :standard -warn-error -a+8)
- (libraries yojson lsp logs threads trace.core))
+ (libraries
+  yojson
+  logs
+  threads
+  trace.core
+  (re_export linol.lsp)
+  (re_export linol.jsonrpc)))

src/eio/dune

@@ -1,5 +1,5 @@
 (library
  (name linol_eio)
  (public_name linol-eio)
- (libraries eio eio.unix linol)
+ (libraries eio eio.unix linol linol.lsp linol.jsonrpc)
  (flags :standard -warn-error -a))

src/eio/linol_eio.ml

@@ -1,3 +1,7 @@
+open struct
+  module Lsp = Linol_lsp.Lsp
+end
+
 module type IO = Linol.IO
 
 module IO_eio :
@@ -15,11 +19,15 @@ module IO_eio :
   let failwith = failwith
   let fail = raise
 
-  let catch f handler = try f () with exn ->
-    let bt = Printexc.get_raw_backtrace () in
-    handler exn bt
+  let catch f handler =
+    try f ()
+    with exn ->
+      let bt = Printexc.get_raw_backtrace () in
+      handler exn bt
+
+  let stdin env =
+    Eio.Buf_read.of_flow ~max_size:1_000_000 (Eio.Stdenv.stdin env)
 
-  let stdin env = Eio.Buf_read.of_flow ~max_size:1_000_000 (Eio.Stdenv.stdin env)
   let stdout = Eio.Stdenv.stdout
 
   type env = Eio_unix.Stdenv.base
@@ -27,29 +35,28 @@ module IO_eio :
   type out_channel = Eio_unix.sink_ty Eio.Std.r
 
   let write_string out_ch str = Eio.Flow.copy_string str out_ch
+
   let write out_ch bytes off len =
     Eio.Buf_write.with_flow out_ch @@ fun w ->
     Eio.Buf_write.bytes w ~off ~len bytes
+
   let read in_ch bytes off len =
     let str = Eio.Buf_read.take len in_ch in
     Bytes.blit_string str off bytes 0 len
-  let read_line in_ch =
-    Eio.Buf_read.line in_ch
+
+  let read_line in_ch = Eio.Buf_read.line in_ch
 end
 
 (** Spawn function. *)
 let spawn f =
   let promise, resolver = Eio.Promise.create () in
-  begin
-    try
-      f ();
-      Eio.Promise.resolve_ok resolver ()
-    with
-      exn ->
-      (Printf.eprintf "uncaught exception in `spawn`:\n%s\n%!"
-        (Printexc.to_string exn));
-      Eio.Promise.resolve_error resolver exn
-    end;
+  (try
+     f ();
+     Eio.Promise.resolve_ok resolver ()
+   with exn ->
+     Printf.eprintf "uncaught exception in `spawn`:\n%s\n%!"
+       (Printexc.to_string exn);
+     Eio.Promise.resolve_error resolver exn);
 
   Eio.Promise.await_exn promise
 

src/jsonrpc2.ml

@@ -22,7 +22,11 @@ module type S = sig
     t
 
   val create_stdio :
-    ?on_received:(json -> unit) -> ?on_sent:(json -> unit) -> env:IO.env -> server -> t
+    ?on_received:(json -> unit) ->
+    ?on_sent:(json -> unit) ->
+    env:IO.env ->
+    server ->
+    t
 
   val send_server_notification : t -> Lsp.Server_notification.t -> unit IO.t
 
@@ -120,7 +124,8 @@ module Make (IO : IO) : S with module IO = IO = struct
     `Int id
 
   (** Registers a new handler for a request response. The return indicates
-      whether a value was inserted or not (in which case it's already present). *)
+      whether a value was inserted or not (in which case it's already present).
+  *)
   let register_server_request_response_handler (self : t) (id : Req_id.t)
       (handler : server_request_handler_pair) : bool =
     if Hashtbl.mem self.pending_responses id then
@@ -359,10 +364,10 @@ module Make (IO : IO) : S with module IO = IO = struct
       Req_id.t IO.t =
     server_request self (Request_and_handler (req, cb))
 
-  (** [shutdown ()] is called after processing each request to check if the server
-    could wait for new messages.
-    When launching an LSP server using [Server.Make.server], the
-    natural choice for it is [s#get_status = `ReceivedExit] *)
+  (** [shutdown ()] is called after processing each request to check if the
+      server could wait for new messages. When launching an LSP server using
+      [Server.Make.server], the natural choice for it is
+      [s#get_status = `ReceivedExit] *)
   let run ?(shutdown = fun _ -> false) (self : t) : unit IO.t =
     let async f =
       self.s#spawn_query_handler f;

src/jsonrpc2.mli

@@ -1,6 +1,8 @@
 (** Simple JSON-RPC2 implementation.
 
-    See {{: https://www.jsonrpc.org/specification} the spec} *)
+    See {{:https://www.jsonrpc.org/specification} the spec} *)
+
+open Common_
 
 type json = Yojson.Safe.t
 
@@ -24,7 +26,11 @@ module type S = sig
   (** Create a connection from the pair of channels *)
 
   val create_stdio :
-    ?on_received:(json -> unit) -> ?on_sent:(json -> unit) -> env:IO.env -> server -> t
+    ?on_received:(json -> unit) ->
+    ?on_sent:(json -> unit) ->
+    env:IO.env ->
+    server ->
+    t
   (** Create a connection using stdin/stdout *)
 
   val send_server_notification : t -> Lsp.Server_notification.t -> unit IO.t
@@ -36,13 +42,13 @@ module type S = sig
     'from_server Lsp.Server_request.t ->
     (('from_server, Jsonrpc.Response.Error.t) result -> unit IO.t) ->
     Req_id.t IO.t
-  (** Send a request from the server, and pass a callback that will be
-      called with the result in the future.
+  (** Send a request from the server, and pass a callback that will be called
+      with the result in the future.
       @since 0.5 *)
 
   val run : ?shutdown:(unit -> bool) -> t -> unit IO.t
   (** Listen for incoming messages and responses.
-    @param shutdown if true, tells the server to shut down *)
+      @param shutdown if true, tells the server to shut down *)
 end
 
 module Make (IO : IO) : S with module IO = IO

src/linol.ml

@@ -1,10 +1,17 @@
 (** Linol.
 
-    Abstraction over The "Lsp" library, to make it easier to develop
-    LSP servers in OCaml (but not necessarily {b for} OCaml). *)
+    Abstraction over The "Lsp" library, to make it easier to develop LSP servers
+    in OCaml (but not necessarily {b for} OCaml). *)
 
 module type IO = Sigs.IO
 
+(** {2 Re-export from vendored lsp} *)
+
+module Lsp = Linol_lsp.Lsp
+module Jsonrpc = Linol_jsonrpc.Jsonrpc
+
+(** {2 Main modules} *)
+
 module Jsonrpc2 = Jsonrpc2
 module Server = Server
 module Blocking_IO = Blocking_IO

src/lwt/dune

@@ -1,5 +1,5 @@
 (library
  (name linol_lwt)
  (public_name linol-lwt)
- (libraries yojson lwt lwt.unix linol lsp jsonrpc)
+ (libraries yojson lwt lwt.unix linol linol.lsp linol.jsonrpc)
  (flags :standard -warn-error -a))

src/lwt/linol_lwt.ml

@@ -1,3 +1,7 @@
+open struct
+  module Lsp = Linol_lsp.Lsp
+end
+
 module type IO = Linol.IO
 
 module IO_lwt :
@@ -18,8 +22,8 @@ module IO_lwt :
 
   let return = Lwt.return
   let failwith = Lwt.fail_with
-  let stdin = fun () -> Lwt_io.stdin
-  let stdout = fun () -> Lwt_io.stdout
+  let stdin () = Lwt_io.stdin
+  let stdout () = Lwt_io.stdout
 
   type env = unit
   type in_channel = Lwt_io.input Lwt_io.channel

src/server.ml

@@ -13,7 +13,8 @@ type nonrec doc_state = {
 
 (** Request ID.
 
-    The unique ID of a request, used by JSONRPC to map each request to its reply. *)
+    The unique ID of a request, used by JSONRPC to map each request to its
+    reply. *)
 module Req_id = struct
   type t = Jsonrpc.Id.t
 
@@ -62,16 +63,18 @@ module Make (IO : IO) = struct
             'a Lsp.Client_request.t ->
             ('a, string) result IO.t
       (** Method called to handle client requests.
-        @param notify_back an object used to reply to the client, send progress
-        messages, diagnostics, etc.
-        @param id the query RPC ID, can be used for tracing, cancellation, etc. *)
+          @param notify_back
+            an object used to reply to the client, send progress messages,
+            diagnostics, etc.
+          @param id
+            the query RPC ID, can be used for tracing, cancellation, etc. *)
 
       method must_quit = false
       (** Set to true if the client requested to exit *)
 
       method virtual spawn_query_handler : (unit -> unit IO.t) -> unit
-      (** How to start a new future/task/thread concurrently. This is used
-          to process incoming user queries.
+      (** How to start a new future/task/thread concurrently. This is used to
+          process incoming user queries.
           @since 0.5 *)
     end
 
@@ -116,8 +119,8 @@ module Make (IO : IO) = struct
       method cancel_request (id : Jsonrpc.Id.t) : unit IO.t =
         notify_back @@ CancelRequest id
 
-      method work_done_progress_begin (p : Lsp.Types.WorkDoneProgressBegin.t)
-          : unit IO.t =
+      method work_done_progress_begin (p : Lsp.Types.WorkDoneProgressBegin.t) :
+          unit IO.t =
         match workDoneToken with
         | Some token ->
           notify_back @@ WorkDoneProgress { token; value = Begin p }
@@ -130,23 +133,25 @@ module Make (IO : IO) = struct
           notify_back @@ WorkDoneProgress { value = Report p; token }
         | None -> IO.return ()
 
-      method work_done_progress_end (p : Lsp.Types.WorkDoneProgressEnd.t)
-          : unit IO.t =
+      method work_done_progress_end (p : Lsp.Types.WorkDoneProgressEnd.t) :
+          unit IO.t =
         match workDoneToken with
         | Some token -> notify_back @@ WorkDoneProgress { value = End p; token }
         | None -> IO.return ()
 
       method send_notification (n : Lsp.Server_notification.t) : unit IO.t =
         notify_back n
-      (** Send a notification from the server to the client (general purpose method) *)
+      (** Send a notification from the server to the client (general purpose
+          method) *)
 
-      method send_request
-          : 'from_server.
-            'from_server Lsp.Server_request.t ->
-            (('from_server, Jsonrpc.Response.Error.t) result -> unit IO.t) ->
-            Req_id.t IO.t =
+      method send_request :
+          'from_server.
+          'from_server Lsp.Server_request.t ->
+          (('from_server, Jsonrpc.Response.Error.t) result -> unit IO.t) ->
+          Req_id.t IO.t =
         fun r h -> server_request @@ Request_and_handler (r, h)
-      (** Send a request from the server to the client (general purpose method) *)
+      (** Send a request from the server to the client (general purpose method)
+      *)
     end
 
   type nonrec doc_state = doc_state = {
@@ -162,10 +167,10 @@ module Make (IO : IO) = struct
     let+ x = x in
     Ok x
 
-  (** An easily overloadable class. Pick the methods you want to support.
-      The user must provide at least the callbacks for document lifecycle:
-      open, close, update. The most basic LSP server should check documents
-      when they're updated and report diagnostics back to the editor. *)
+  (** An easily overloadable class. Pick the methods you want to support. The
+      user must provide at least the callbacks for document lifecycle: open,
+      close, update. The most basic LSP server should check documents when
+      they're updated and report diagnostics back to the editor. *)
   class virtual server =
     object (self)
       inherit base_server
@@ -178,7 +183,7 @@ module Make (IO : IO) = struct
 
       method get_status = status
       (** Check if exit or shutdown request was made by the client.
-        @since 0.5 *)
+          @since 0.5 *)
 
       method find_doc (uri : DocumentUri.t) : doc_state option =
         try Some (Hashtbl.find docs uri) with Not_found -> None
@@ -223,50 +228,47 @@ module Make (IO : IO) = struct
 
       method config_completion : CompletionOptions.t option = None
       (** Configuration for the completion API.
-        @since 0.4 *)
+          @since 0.4 *)
 
       method config_code_lens_options : CodeLensOptions.t option = None
       (** @since 0.3 *)
 
-      method config_definition
-          : [ `Bool of bool | `DefinitionOptions of DefinitionOptions.t ] option
-          =
+      method config_definition :
+          [ `Bool of bool | `DefinitionOptions of DefinitionOptions.t ] option =
         None
       (** @since 0.3 *)
 
-      method config_hover
-          : [ `Bool of bool | `HoverOptions of HoverOptions.t ] option =
+      method config_hover :
+          [ `Bool of bool | `HoverOptions of HoverOptions.t ] option =
         None
       (** @since 0.3 *)
 
-      method config_inlay_hints
-          : [ `Bool of bool
-            | `InlayHintOptions of InlayHintOptions.t
-            | `InlayHintRegistrationOptions of InlayHintRegistrationOptions.t
-            ]
-            option =
+      method config_inlay_hints :
+          [ `Bool of bool
+          | `InlayHintOptions of InlayHintOptions.t
+          | `InlayHintRegistrationOptions of InlayHintRegistrationOptions.t
+          ]
+          option =
         None
       (** Configuration for the inlay hints API. *)
 
-      method config_symbol
-          : [ `Bool of bool
-            | `DocumentSymbolOptions of DocumentSymbolOptions.t
-            ]
-            option =
+      method config_symbol :
+          [ `Bool of bool | `DocumentSymbolOptions of DocumentSymbolOptions.t ]
+          option =
         None
       (** @since 0.3 *)
 
-      method config_code_action_provider
-          : [ `CodeActionOptions of CodeActionOptions.t | `Bool of bool ] =
+      method config_code_action_provider :
+          [ `CodeActionOptions of CodeActionOptions.t | `Bool of bool ] =
         `Bool false
       (** @since 0.3 *)
 
-      method config_modify_capabilities (c : ServerCapabilities.t)
-          : ServerCapabilities.t =
+      method config_modify_capabilities (c : ServerCapabilities.t) :
+          ServerCapabilities.t =
         c
-      (** Modify capabilities before sending them back to the client.
-        By default we just return them unmodified.
-        @since 0.3 *)
+      (** Modify capabilities before sending them back to the client. By default
+          we just return them unmodified.
+          @since 0.3 *)
 
       method config_list_commands : string list = []
       (** List of commands available *)
@@ -304,73 +306,73 @@ module Make (IO : IO) = struct
       (** Called when the user hovers on some identifier in the document *)
 
       method on_req_completion ~notify_back:(_ : notify_back) ~id:_ ~uri:_
-          ~pos:_ ~ctx:_ ~workDoneToken:_ ~partialResultToken:_ (_ : doc_state)
-          : [ `CompletionList of CompletionList.t
-            | `List of CompletionItem.t list
-            ]
-            option
-            IO.t =
+          ~pos:_ ~ctx:_ ~workDoneToken:_ ~partialResultToken:_ (_ : doc_state) :
+          [ `CompletionList of CompletionList.t
+          | `List of CompletionItem.t list
+          ]
+          option
+          IO.t =
         IO.return None
       (** Called when the user requests completion in the document *)
 
       method on_req_definition ~notify_back:(_ : notify_back) ~id:_ ~uri:_
-          ~pos:_ ~workDoneToken:_ ~partialResultToken:_ (_ : doc_state)
-          : Locations.t option IO.t =
+          ~pos:_ ~workDoneToken:_ ~partialResultToken:_ (_ : doc_state) :
+          Locations.t option IO.t =
         IO.return None
-      (** Called when the user wants to jump-to-definition  *)
+      (** Called when the user wants to jump-to-definition *)
 
       method on_req_code_lens ~notify_back:(_ : notify_back) ~id:_ ~uri:_
-          ~workDoneToken:_ ~partialResultToken:_ (_ : doc_state)
-          : CodeLens.t list IO.t =
+          ~workDoneToken:_ ~partialResultToken:_ (_ : doc_state) :
+          CodeLens.t list IO.t =
         IO.return []
       (** List code lenses for the given document
-        @since 0.3 *)
+          @since 0.3 *)
 
       method on_req_code_lens_resolve ~notify_back:(_ : notify_back) ~id:_
           (cl : CodeLens.t) : CodeLens.t IO.t =
         IO.return cl
       (** Code lens resolution, must return a code lens with non null "command"
-        @since 0.3 *)
+          @since 0.3 *)
 
       method on_req_code_action ~notify_back:(_ : notify_back) ~id:_
           (_c : CodeActionParams.t) : CodeActionResult.t IO.t =
         IO.return None
       (** Code action.
-        @since 0.3 *)
+          @since 0.3 *)
 
       method on_req_execute_command ~notify_back:(_ : notify_back) ~id:_
-          ~workDoneToken:_ (_c : string) (_args : Yojson.Safe.t list option)
-          : Yojson.Safe.t IO.t =
+          ~workDoneToken:_ (_c : string) (_args : Yojson.Safe.t list option) :
+          Yojson.Safe.t IO.t =
         IO.return `Null
       (** Execute a command with given arguments.
-        @since 0.3 *)
+          @since 0.3 *)
 
       method on_req_symbol ~notify_back:(_ : notify_back) ~id:_ ~uri:_
-          ~workDoneToken:_ ~partialResultToken:_ ()
-          : [ `DocumentSymbol of DocumentSymbol.t list
-            | `SymbolInformation of SymbolInformation.t list
-            ]
-            option
-            IO.t =
+          ~workDoneToken:_ ~partialResultToken:_ () :
+          [ `DocumentSymbol of DocumentSymbol.t list
+          | `SymbolInformation of SymbolInformation.t list
+          ]
+          option
+          IO.t =
         IO.return None
       (** List symbols in this document.
-        @since 0.3 *)
+          @since 0.3 *)
 
       method on_unknown_request ~notify_back:(_ : notify_back) ~server_request:_
           ~id:_ _meth _params : Yojson.Safe.t IO.t =
         IO.failwith "unhandled request"
 
       method on_req_inlay_hint ~notify_back:(_ : notify_back) ~id:_ ~uri:_
-          ~range:(_ : Lsp.Types.Range.t) ()
-          : Lsp.Types.InlayHint.t list option IO.t =
+          ~range:(_ : Lsp.Types.Range.t) () :
+          Lsp.Types.InlayHint.t list option IO.t =
         IO.return None
       (** Provide inlay hints for this document.
-        @since 0.5 *)
+          @since 0.5 *)
 
       method on_req_shutdown ~notify_back:(_ : notify_back) ~id:_ : unit IO.t =
         IO.return ()
       (** Process a shutdown request.
-        @since 0.7 *)
+          @since 0.7 *)
 
       method on_request : type r.
           notify_back:_ ->
@@ -627,6 +629,11 @@ module Make (IO : IO) = struct
         IO.return ()
       (** Override to handle unprocessed notifications *)
 
+      method filter_text_document (_doc_uri : Lsp.Types.DocumentUri.t) : bool =
+        true
+      (** Filter the document URI to check if we want to process it or not. By
+          default we accept all documents. *)
+
       method on_notification ~notify_back ~server_request
           (n : Lsp.Client_notification.t) : unit IO.t =
         let@ _sp =
@@ -651,105 +658,121 @@ module Make (IO : IO) = struct
         match n with
         | Lsp.Client_notification.TextDocumentDidOpen
             { DidOpenTextDocumentParams.textDocument = doc } ->
-          Log.debug (fun k ->
-              k "notif: did open '%s'" (DocumentUri.to_path doc.uri));
-          let notify_back =
-            new notify_back
-              ~uri:doc.uri ~workDoneToken:None ~partialResultToken:None
-              ~version:doc.version ~notify_back ~server_request ()
-          in
-          let st =
-            {
-              uri = doc.uri;
-              version = doc.version;
-              content = doc.text;
-              languageId = doc.languageId;
-            }
-          in
-          Hashtbl.replace docs doc.uri st;
+          if not (self#filter_text_document doc.uri) then
+            IO.return ()
+          else (
+            Log.debug (fun k ->
+                k "notif: did open '%s'" (DocumentUri.to_path doc.uri));
+            let notify_back =
+              new notify_back
+                ~uri:doc.uri ~workDoneToken:None ~partialResultToken:None
+                ~version:doc.version ~notify_back ~server_request ()
+            in
+            let st =
+              {
+                uri = doc.uri;
+                version = doc.version;
+                content = doc.text;
+                languageId = doc.languageId;
+              }
+            in
+            Hashtbl.replace docs doc.uri st;
 
-          async self (fun () ->
-              self#on_notif_doc_did_open
-                ~notify_back:(notify_back : notify_back)
-                doc ~content:st.content)
+            async self (fun () ->
+                self#on_notif_doc_did_open
+                  ~notify_back:(notify_back : notify_back)
+                  doc ~content:st.content)
+          )
         | Lsp.Client_notification.TextDocumentDidClose { textDocument = doc } ->
-          Log.debug (fun k ->
-              k "notif: did close '%s'" (DocumentUri.to_path doc.uri));
-          let notify_back =
-            new notify_back
-              ~workDoneToken:None ~partialResultToken:None ~uri:doc.uri
-              ~notify_back ~server_request ()
-          in
+          if not (self#filter_text_document doc.uri) then
+            IO.return ()
+          else (
+            Log.debug (fun k ->
+                k "notif: did close '%s'" (DocumentUri.to_path doc.uri));
+            let notify_back =
+              new notify_back
+                ~workDoneToken:None ~partialResultToken:None ~uri:doc.uri
+                ~notify_back ~server_request ()
+            in
 
-          async self (fun () ->
-              self#on_notif_doc_did_close
-                ~notify_back:(notify_back : notify_back)
-                doc)
+            async self (fun () ->
+                self#on_notif_doc_did_close
+                  ~notify_back:(notify_back : notify_back)
+                  doc)
+          )
         | Lsp.Client_notification.TextDocumentDidChange
             { textDocument = doc; contentChanges = c } ->
-          Log.debug (fun k ->
-              k "notif: did change '%s'" (DocumentUri.to_path doc.uri));
-          let notify_back =
-            new notify_back
-              ~workDoneToken:None ~partialResultToken:None ~uri:doc.uri
-              ~notify_back ~server_request ()
-          in
+          if not (self#filter_text_document doc.uri) then
+            IO.return ()
+          else (
+            Log.debug (fun k ->
+                k "notif: did change '%s'" (DocumentUri.to_path doc.uri));
+            let notify_back =
+              new notify_back
+                ~workDoneToken:None ~partialResultToken:None ~uri:doc.uri
+                ~notify_back ~server_request ()
+            in
 
-          let old_doc =
-            match Hashtbl.find_opt docs doc.uri with
-            | None ->
-              (* WTF vscode. Well let's try and deal with it. *)
-              Log.err (fun k ->
-                  k "unknown document: '%s'" (DocumentUri.to_path doc.uri));
-              let version = doc.version in
+            let old_doc =
+              match Hashtbl.find_opt docs doc.uri with
+              | None ->
+                (* WTF vscode. Well let's try and deal with it. *)
+                Log.err (fun k ->
+                    k "unknown document: '%s'" (DocumentUri.to_path doc.uri));
+                let version = doc.version in
 
-              let languageId = "" in
-              (* FIXME*)
-              Lsp.Text_document.make ~position_encoding:positionEncoding
-                (DidOpenTextDocumentParams.create
-                   ~textDocument:
-                     (TextDocumentItem.create ~languageId ~uri:doc.uri ~version
-                        ~text:""))
-            | Some st ->
-              Lsp.Text_document.make ~position_encoding:positionEncoding
-                (DidOpenTextDocumentParams.create
-                   ~textDocument:
-                     (TextDocumentItem.create ~languageId:st.languageId
-                        ~uri:doc.uri ~version:st.version ~text:st.content))
-          in
+                let languageId = "" in
+                (* FIXME*)
+                Lsp.Text_document.make ~position_encoding:positionEncoding
+                  (DidOpenTextDocumentParams.create
+                     ~textDocument:
+                       (TextDocumentItem.create ~languageId ~uri:doc.uri
+                          ~version ~text:""))
+              | Some st ->
+                Lsp.Text_document.make ~position_encoding:positionEncoding
+                  (DidOpenTextDocumentParams.create
+                     ~textDocument:
+                       (TextDocumentItem.create ~languageId:st.languageId
+                          ~uri:doc.uri ~version:st.version ~text:st.content))
+            in
 
-          let new_doc : Lsp.Text_document.t =
-            Lsp.Text_document.apply_content_changes old_doc c
-          in
+            let new_doc : Lsp.Text_document.t =
+              Lsp.Text_document.apply_content_changes old_doc c
+            in
 
-          let new_st : doc_state =
-            {
-              uri = doc.uri;
-              languageId = Lsp.Text_document.languageId new_doc;
-              content = Lsp.Text_document.text new_doc;
-              version = Lsp.Text_document.version new_doc;
-            }
-          in
+            let new_st : doc_state =
+              {
+                uri = doc.uri;
+                languageId = Lsp.Text_document.languageId new_doc;
+                content = Lsp.Text_document.text new_doc;
+                version = Lsp.Text_document.version new_doc;
+              }
+            in
 
-          Hashtbl.replace docs doc.uri new_st;
+            Hashtbl.replace docs doc.uri new_st;
 
-          async self (fun () ->
-              self#on_notif_doc_did_change
-                ~notify_back:(notify_back : notify_back)
-                doc c
-                ~old_content:(Lsp.Text_document.text old_doc)
-                ~new_content:new_st.content)
+            async self (fun () ->
+                self#on_notif_doc_did_change
+                  ~notify_back:(notify_back : notify_back)
+                  doc c
+                  ~old_content:(Lsp.Text_document.text old_doc)
+                  ~new_content:new_st.content)
+          )
         | Lsp.Client_notification.DidSaveTextDocument params ->
-          let notify_back =
-            new notify_back
-              ~workDoneToken:None ~partialResultToken:None
-              ~uri:params.textDocument.uri ~notify_back ~server_request ()
-          in
+          if not (self#filter_text_document params.textDocument.uri) then
+            IO.return ()
+          else (
+            let notify_back =
+              new notify_back
+                ~workDoneToken:None ~partialResultToken:None
+                ~uri:params.textDocument.uri ~notify_back ~server_request ()
+            in
 
-          async self (fun () ->
-              self#on_notif_doc_did_save
-                ~notify_back:(notify_back : notify_back)
-                params)
+            async self (fun () ->
+                self#on_notif_doc_did_save
+                  ~notify_back:(notify_back : notify_back)
+                  params)
+          )
         | Lsp.Client_notification.Exit ->
           status <- `ReceivedExit;
           IO.return ()

thirdparty/lsp/.editorconfig

@@ -0,0 +1,11 @@
+root = true
+
+[*]
+indent_style = space
+indent_size = 2
+charset = utf-8
+trim_trailing_whitespace = true
+insert_final_newline = true
+
+[Makefile]
+indent_style = tab

thirdparty/lsp/.git-blame-ignore-revs

@@ -0,0 +1,11 @@
+# To understand why we need this file, see https://www.moxio.com/blog/43/ignoring-bulk-change-commits-with-git-blame
+
+# add ocamlformat config `wrap-fun-args=false`
+
+75504946eaa6f817550b649df508d61dde12bbda
+# Upgrade to OCamlformat 0.26.0
+ab49baa5873e7f0b9181dbed3ad89681f1e4bcee
+# Upgrade to OCamlformat 0.26.1
+1a6419bac3ce012deb9c6891e6b25e2486c33388
+# Upgrade to OCamlformat 0.27.0
+2ccbee5dd691690228307d3636e2f82c8cdb3902

thirdparty/lsp/.github/dependabot.yml

@@ -0,0 +1,16 @@
+version: 2
+updates:
+  - package-ecosystem: github-actions
+    directory: /
+    schedule:
+      interval: weekly
+    labels:
+      - dependencies
+      - no changelog
+  - package-ecosystem: npm
+    directory: /
+    schedule:
+      interval: daily
+    labels:
+      - dependencies
+      - no changelog

thirdparty/lsp/.github/workflows/build-and-test.yml

@@ -0,0 +1,103 @@
+name: Build and Test
+
+on:
+  pull_request:
+  push:
+    branches:
+      - master
+  schedule:
+    # Prime the caches every Monday
+    - cron: 0 1 * * MON
+
+jobs:
+  build-and-test:
+    name: Build and Test
+
+    strategy:
+      fail-fast: false
+      matrix:
+        os:
+          - ubuntu-latest
+          - macos-latest
+          - windows-latest
+
+    runs-on: ${{ matrix.os }}
+
+    steps:
+      - name: Set git to use LF
+        run: |
+          git config --global core.autocrlf false
+          git config --global core.eol lf
+
+      - name: Checkout tree
+        uses: actions/checkout@v4
+        with:
+          submodules: true
+
+      - name: Set-up Node.js
+        uses: actions/setup-node@v4
+        with:
+          node-version: lts/*
+
+      - name: Install npm packages
+        run: yarn install --frozen-lockfile
+
+      - name: Set-up OCaml
+        uses: ocaml/setup-ocaml@v3
+        with:
+          ocaml-compiler: "ocaml-base-compiler.5.3.0"
+
+      # Remove this pin once a compatible version of Merlin has been released
+      - name: Pin dev Merlin
+        run: opam --cli=2.1 pin --with-version=5.4-503 https://github.com/ocaml/merlin.git#main
+
+      - name: Build and install dependencies
+        run: opam install .
+
+      # the makefile explains why we don't use --with-test
+      # ppx expect is not yet compatible with 5.1 and test output vary from one
+      # compiler to another. We only test on 4.14.
+      - name: Install test dependencies
+        run: opam exec -- make install-test-deps
+
+      - name: Run build @all
+        run: opam exec -- make all
+
+      - name: Run the unit tests
+        run: opam exec -- make test-ocaml
+
+      - name: Run the template integration tests
+        run: opam exec -- make test-e2e
+
+  coverage:
+    name: Coverage
+    runs-on: ubuntu-latest
+    steps:
+      - name: Checkout tree
+        uses: actions/checkout@v4
+        with:
+          submodules: true
+
+      - name: Set-up OCaml
+        uses: ocaml/setup-ocaml@v3
+        with:
+          ocaml-compiler: "ocaml-base-compiler.5.3.0"
+
+      - name: Set git user
+        run: |
+          git config --global user.name github-actions[bot]
+          git config --global user.email github-actions[bot]@users.noreply.github.com
+
+      # Remove this pin once a compatible version of Merlin has been released
+      - name: Pin dev Merlin
+        run: opam --cli=2.1 pin --with-version=5.4-503 https://github.com/ocaml/merlin.git#main
+
+      - name: Install dependencies
+        run: |
+          opam install . --deps-only
+          opam exec -- make coverage-deps install-test-deps
+
+      - run: opam exec -- make test-coverage
+        env:
+          COVERALLS_REPO_TOKEN: ${{ github.token }}
+          PULL_REQUEST_NUMBER: ${{ github.event.number }}

thirdparty/lsp/.github/workflows/changelog.yml

@@ -0,0 +1,13 @@
+name: Changelog check
+
+on:
+  pull_request:
+    branches: [master]
+    types: [opened, synchronize, reopened, labeled, unlabeled]
+
+jobs:
+  Changelog-Entry-Check:
+    name: Check Changelog Action
+    runs-on: ubuntu-latest
+    steps:
+      - uses: tarides/changelog-check-action@v3

thirdparty/lsp/.github/workflows/nix.yml

@@ -0,0 +1,31 @@
+name: "Nix"
+on:
+  pull_request:
+  push:
+    branches:
+      - master
+jobs:
+  # tests:
+  #   runs-on: ubuntu-latest
+  #   steps:
+  #     - name: Checkout tree
+  #       uses: actions/checkout@v4
+  #       with:
+  #         submodules: true
+  #     - name: nix
+  #       uses: cachix/install-nix-action@v30
+  #       with:
+  #         nix_path: nixpkgs=channel:nixos-unstable
+  #     - run: nix develop .#check -c make nix-tests
+  fmt:
+    runs-on: ubuntu-latest
+    steps:
+      - name: Checkout tree
+        uses: actions/checkout@v4
+        with:
+          submodules: true
+      - name: nix
+        uses: cachix/install-nix-action@v30
+        with:
+          nix_path: nixpkgs=channel:nixos-unstable
+      - run: nix develop .#fmt -c make nix-fmt

thirdparty/lsp/.github/workflows/update-flake-lock.yml

@@ -0,0 +1,21 @@
+name: Update Nix Flake Lock
+
+on:
+  workflow_dispatch:
+  schedule:
+    - cron: 0 0 * * 0
+
+jobs:
+  lockfile:
+    runs-on: ubuntu-latest
+    steps:
+      - name: Checkout code
+        uses: actions/checkout@v4
+      - uses: cachix/install-nix-action@v30
+        with:
+          nix_path: nixpkgs=channel:nixos-unstable
+      - uses: DeterminateSystems/update-flake-lock@v24
+        with:
+          pr-labels: |
+            dependencies
+            no changelog

thirdparty/lsp/.gitignore

@@ -0,0 +1,12 @@
+_build/
+_opam/
+.idea/
+.log/
+.vscode/
+node_modules/
+tmp/
+.DS_Store
+.merlin
+*.install
+*.log
+result

thirdparty/lsp/.ocamlformat

@@ -0,0 +1,3 @@
+version=0.27.0
+profile=janestreet
+ocaml-version=4.14.0

thirdparty/lsp/.ocamlformat-ignore

@@ -0,0 +1,3 @@
+vendor
+_opam
+_esy

thirdparty/lsp/CHANGES.md

@@ -0,0 +1,769 @@
+# 1.22.0
+
+## Features
+
+- Enable experimental project-wide renaming of identifiers (#1431)
+
+# 1.21.0
+
+## Features
+
+- Add a new server option `standardHover`, that can be used by clients to
+  disable the default hover provider.  When `standardHover = false`
+  `textDocument/hover` requests always returns with empty result. (#1416)
+
+# 1.20.1
+
+## Fixes
+
+- Deactivate the `jump` code actions by default. Clients can enable them with
+  the `merlinJumpCodeActions` configuration option. Alternatively a custom
+  request is provided for ad hoc use of the feature. (#1411)
+
+# 1.20.0
+
+## Features
+
+- Add custom
+  [`ocamllsp/typeSearch`](/ocaml-lsp-server/docs/ocamllsp/typeSearch-spec.md) request (#1369)
+
+- Make MerlinJump code action configurable (#1376)
+- Add support for OCaml 5.3 (#1386)
+
+- Add custom [`ocamllsp/jump`](/ocaml-lsp-server/docs/ocamllsp/merlinJump-spec.md) request (#1374)
+
+## Fixes
+
+- Fix fd leak in running external processes for preprocessing (#1349)
+
+- Fix prefix parsing for completion of object methods (#1363, fixes #1358)
+
+- Remove some duplicates in the `selectionRange` answers (#1368)
+
+# 1.19.0
+
+## Features
+
+- Add custom [`ocamllsp/getDocumentation`](/ocaml-lsp-server/docs/ocamllsp/getDocumentation-spec.md) request (#1336)
+
+- Add support for OCaml 5.2 (#1233)
+
+- Add a code-action for syntactic and semantic movement shortcuts based on Merlin's Jump command (#1364)
+
+## Fixes
+
+- Kill unnecessary ocamlformat processes with sigterm rather than sigint or
+  sigkill (#1343)
+
+## Features
+
+- Add custom [`ocamllsp/construct`](https://github.com/ocaml/ocaml-lsp/blob/ocaml-lsp-server/docs/ocamllsp/construct-spec.md) request (#1348)
+
+# 1.18.0
+
+## Features
+
+- Introduce a configuration option to control dune diagnostics. The option is
+  called `duneDiganostics` and it may be set to `{ enable: false }` to disable
+  diagnostics. (#1221)
+
+- Support folding of `ifthenelse` expressions (#1031)
+
+- Improve hover behavior (#1245)
+
+  Hovers are no longer displaye on useless parsetree nodes such as keywords,
+  comments, etc.
+
+  Multiline hovers are now filtered away.
+
+  Display expanded ppx's in the hover window.
+
+- Improve document symbols (#1247)
+
+  Use the parse tree instead of the typed tree. This means that document
+  symbols will work even if the source code doesn't type check.
+
+  Include symbols at arbitrary depth.
+
+  Differentiate functions / types / variants / etc.
+
+  This now includes PPXs like `let%expect_test` or `let%bench` in the outline.
+
+- Introduce a `destruct-line` code action. This is an improved version of the
+  old `destruct` code action. (#1283)
+
+- Improve signature inference to only include types for elements that were
+  absent from the signature. Previously, all signature items would always be
+  inserted. (#1289)
+
+- Add an `update-signature` code action to update the types of elements that
+  were already present in the signature (#1289)
+
+- Add custom
+  [`ocamllsp/merlinCallCompatible`](https://github.com/ocaml/ocaml-lsp/blob/e165f6a3962c356adc7364b9ca71788e93489dd0/ocaml-lsp-server/docs/ocamllsp/merlinCallCompatible-spec.md)
+  request (#1265)
+
+- Add custom [`ocamllsp/typeEnclosing`](https://github.com/ocaml/ocaml-lsp/blob/109801e56f2060caf4487427bede28b824f4f1fe/ocaml-lsp-server/docs/ocamllsp/typeEnclosing-spec.md) request (#1304)
+
+## Fixes
+
+- Detect document kind by looking at merlin's `suffixes` config.
+
+  This enables more lsp features for non-.ml/.mli files. Though it still
+  depends on merlin's support. (#1237)
+
+- Correctly accept the `--clientProcessId` flag. (#1242)
+
+- Disable automatic completion and signature help inside comments (#1246)
+
+- Includes a new optional/configurable option to toggle syntax documentation. If
+  toggled on, allows display of syntax documentation on hover tooltips. Can be
+  controlled via environment variables and by GUI for VS code. (#1218)
+
+- For completions on labels that the LSP gets from merlin, take into account
+  whether the prefix being completed starts with `~` or `?`. Change the label
+  completions that start with `?` to start with `~` when the prefix being
+  completed starts with `~`. (#1277)
+
+- Fix document syncing (#1278, #1280, fixes #1207)
+
+- Stop generating inlay hints on generated code (#1290)
+
+- Fix parenthesizing of function types in `SignatureHelp` (#1296)
+
+- Fix syntax documentation rendering (#1318)
+
+# 1.17.0
+
+## Fixes
+
+- Fix missing super & subscripts in markdown documentation. (#1170)
+
+- Do not invoke dune at all if `--fallback-read-dot-merlin` flag is on. (#1173)
+
+- Fix semantic highlighting of infix operators that contain '.'. (#1186)
+
+- Disable highlighting unit as an enum member to fix comment highlighting bug. (#1185)
+
+- Improve type-on-hover and type-annotate efficiency by only formatting the type
+  of the first enclosing. (#1191, #1196)
+
+- Fix the encoding of URI's to match how vscode does it (#1197)
+
+- Fix parsing of completion prefixes (#1181)
+
+## Features
+
+- Compatibility with Odoc 2.3.0, with support for the introduced syntax: tables,
+  and "codeblock output" (#1184)
+
+- Display text of references in doc strings (#1166)
+
+- Add mark/remove unused actions for open, types, for loop indexes, modules,
+  match cases, rec, and constructors (#1141)
+- Add inlay hints for types on let bindings (#1159)
+
+- Offer auto-completion for the keyword `in` (#1217)
+
+# 1.16.2
+
+## Fixes
+
+- Fix file permissions used when specifying output files of pp and ppx. (#1153)
+
+# 1.16.1
+
+## Fixes
+
+- Support building with OCaml 5.0 and 5.1 (#1150)
+
+# 1.16.0
+
+## Fixes
+
+- Disable code lens by default. The support can be re-enabled by explicitly
+  setting it in the configuration. (#1134)
+
+- Fix initilization of `ocamlformat-rpc` in some edge cases when ocamlformat is
+  initialized concurrently (#1132)
+
+- Kill unnecessary `$ dune ocaml-merlin` with SIGTERM rather than SIGKILL
+  (#1124)
+
+- Refactor comment parsing to use `odoc-parser` and `cmarkit` instead of
+  `octavius` and `omd` (#1088)
+
+  This allows users who migrated to omd 2.X to install ocaml-lsp-server in the
+  same opam switch.
+
+  We also slightly improved markdown generation support and fixed a couple in
+  the generation of inline heading and module types.
+
+- Allow opening documents that were already open. This is a workaround for
+  neovim's lsp client (#1067)
+
+- Disable type annotation for functions (#1054)
+
+- Respect codeActionLiteralSupport capability (#1046)
+
+- Fix a document syncing issue when utf-16 is the position encoding (#1004)
+
+- Disable "Type-annotate" action for code that is already annotated.
+  ([#1037](https://github.com/ocaml/ocaml-lsp/pull/1037)), fixes
+  [#1036](https://github.com/ocaml/ocaml-lsp/issues/1036)
+
+- Fix semantic highlighting of long identifiers when using preprocessors
+  ([#1049](https://github.com/ocaml/ocaml-lsp/pull/1049), fixes
+  [#1034](https://github.com/ocaml/ocaml-lsp/issues/1034))
+
+- Fix the type of DocumentSelector in cram document registration (#1068)
+
+- Accept the `--clientProcessId` command line argument. (#1074)
+
+- Accept `--port` as a synonym for `--socket`. (#1075)
+
+- Fix connecting to dune rpc on Windows. (#1080)
+
+## Features
+
+- Add "Remove type annotation" code action. (#1039)
+
+- Support settings through `didChangeConfiguration` notification (#1103)
+
+- Add "Extract local" and "Extract function" code actions. (#870)
+
+- Depend directly on `merlin-lib` 4.9 (#1070)
+
+# 1.15.1
+
+## Fixes
+
+- Fix race condition when a document was being edited and dune in watch mode was
+  running ([#1005](https://github.com/ocaml/ocaml-lsp/pull/1005), fixes
+  [#941](https://github.com/ocaml/ocaml-lsp/issues/941),
+  [#1003](https://github.com/ocaml/ocaml-lsp/issues/1003))
+
+# 1.15.0
+
+## Features
+
+- Enable [semantic highlighting](https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#textDocument_semanticTokens)
+  support by default (#933)
+
+- Support connecting over pipes and socket. Pipes on Windows aren't yet
+  supported (#946)
+
+  [More](https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#implementationConsiderations)
+  about communication channels in LSP specification.
+
+- Re-enable `ocamlformat-rpc` for formatting code snippets (but not files and
+  not on Windows) (#920, #939)
+
+  One needs to have installed either `ocamlformat` package version > 0.21.0 or,
+  otherwise, `ocamlformat-rpc` package. Note that previously `ocamlformat-rpc`
+  came in a standalone OPAM package, but since `ocamlformat` version > 0.21.0,
+  it comes within `ocamlformat` package.
+
+- Add custom
+  [`ocamllsp/hoverExtended`](https://github.com/ocaml/ocaml-lsp/blob/e165f6a3962c356adc7364b9ca71788e93489dd0/ocaml-lsp-server/docs/ocamllsp/hoverExtended-spec.md#L1)
+  request (#561)
+
+- Support utf-8 position encoding clients (#919)
+
+  [More](https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#position) about position encoding in LSP specification.
+
+- Show unwrapped module alias types on hovering over module names. This is due
+  to upgrading to merlin 4.7 and using merlin's `verbosity=smart` by default
+  (#942)
+
+## Fixes
+
+- Respect the client's completion item resolve and preSelect capabilities
+  (#925, #936)
+
+- Disable polling for dune's watch mode on Windows and OCaml 4.14.0 (#935)
+
+- Fix semantic highlighting of "long identifiers," e.g., `Foo.Bar.x` (#932)
+
+- Fix syncing of document contents:
+
+  - For ranges that span an entire line (#927)
+  - Previously, whole line edits would incorrectly eat the newline characters (#971)
+
+# 1.14.2
+
+## Fixes
+
+- Fix random requests failing after switching documents (#904, fixes #898)
+
+- Do not offer related diagnostic information unless the user enables in client
+  capabilities (#905)
+
+- Do not offer diagnostic tags unless the client supports them (#909)
+
+- Do not attach extra data to diagnostics unless the client supports this
+  (#910)
+
+- Use /bin/sh instead of /bin/bash. This fixes ocamllsp on NixOS
+
+# 1.14.1
+
+## Fixes
+
+- Fix various server crashes when opening non OCaml/Reason files. Files such as
+  dune, cram, etc. would cause the server to crash. (#884, fixes #871)
+
+- Ignore unknown tags in merlin configuration to improve forward compatibility
+  with Dune. (#883)
+
+# 1.14.0
+
+## Features
+
+- Code action for inlining let bindings within a module or expression. (#847)
+
+- Tag "unused code" and "deprecated" warnings, allowing clients to better
+  display them. (#848)
+
+- Refresh merlin configuration after every dune build in watch mode (#853)
+
+## Fixes
+
+- Respect `showDocument` capabilities. Do not offer commands or code actions
+  that rely on this request without client support. (#836)
+
+- Fix signatureHelp on .mll files: avoid "Document.dune" exceptions
+
+# 1.13.1
+
+## Fixes
+
+- Fix cwd when executing ppx (#805)
+
+# 1.13.0
+
+## Features
+
+- Code actions for jumping to related files (`.ml`, `.mli`, etc.) (#795)
+
+# 1.12.4
+
+- Allow cancellation of workspace symbols requests (#777)
+
+- Fix unintentionally interleaved jsonrpc IO that would corrupt the session
+  (#786)
+
+- Ignore `SIGPIPE` . (#788)
+
+# 1.12.3
+
+## Fixes
+
+- Fix a bad interaction between inferred interfaces and promotion code actions
+  in watch mode (#753)
+
+- Fix URI parsing (#739 fixes #471 and #459)
+
+# 1.12.2
+
+## Fixes
+
+- Fix shutting down an already closed socket (#740)
+
+# 1.12.1
+
+## Fixes
+
+- Fix preprocessing, ppx, and reason support (#735 fixes #696, #706)
+
+- Support `include` in folding ranges (#730)
+
+# 1.12.0
+
+## Features
+
+- Fix cancellation mechanism for all requests (#707)
+
+- Allow cancellation of formatting requests (#707)
+
+- Add `--fallback-read-dot-merlin` to the LSP Server (#705). If `ocamllsp` is
+  started with this new flag, it will fall back to looking for Merlin
+  configuration in `.merlin` files rather than calling `dune ocaml-merlin`.
+  (#705)
+
+- Support folding more ranges (#692)
+
+# 1.11.6
+
+## Fixes
+
+- Stop leaking file descriptors like a sieve (#701)
+
+# 1.11.5
+
+- Fix process termination. Once the lsp server is stepped, the process will
+  gracefully terminate (#697, fixes #694)
+
+- Forward stderr from dune's merlin configuration to the lsp server's stderr
+  (#697)
+
+# 1.11.4
+
+## Fixes
+
+- Fix bug with large buffers being resized incorrectly in Lev
+
+- Add folding ranges for more AST types (#680)
+
+# 1.11.3
+
+## Fixes
+
+- Enable dune rpc integration by default (#691, fixes #690)
+
+# 1.11.2
+
+## Fixes
+
+- Fix running external processes on Windows
+
+# 1.11.1
+
+## Fixes
+
+- Fix Uri handling on Windows
+
+- Fix build on MSVC 2015
+
+# 1.11.0
+
+## Features
+
+- Add support for dune in watch mode. The lsp server will now display build
+  errors in the diagnostics and offer promotion code actions.
+
+- Re-introduce ocamlformat-rpc (#599, fixes #495)
+
+## Fixes
+
+- Fix workspace symbols that could have a wrong path in some cases
+  ([#675](https://github.com/ocaml/ocaml-lsp/pull/671))
+
+# 1.10.6
+
+## Fixes
+
+- Compatiblity with OCaml 4.14.0
+
+# 1.10.5
+
+## Fixes
+
+- Patch merlin to remove the result module
+
+# 1.10.4
+
+## Fixes
+
+- Use newer versions of ocamlformat-rpc-lib (fixes #697)
+
+# 1.10.3
+
+## Fixes
+
+- Fix more debouncing bugs (#629)
+
+# 1.10.2
+
+## Fixes
+
+- Catch merlin desturct exceptions (#626)
+
+- Fix broken debouncing (#627)
+
+# 1.10.1
+
+## Fixes
+
+- Fix executing ppx executables
+
+# 1.10.0
+
+## Features
+
+- Add better support for code folding: more folds and more precise folds
+
+## Fixes
+
+- Fix infer interface code action crash when implementation source does not
+  exist (#597)
+
+- Improve error message when the reason plugin for merlin is absent (#608)
+
+- Fix `chdir` races when running ppx (#550)
+
+- More accurate completion kinds.
+  New completion kinds for variants and fields. Removed inaccurate completion
+  kinds for constructors and types. (#510)
+
+- Fix handling request cancellation (#616)
+
+# 1.9.1
+
+## Fixes
+
+- Disable functionality reliant on ocamlformat-rpc for now (#555)
+
+- 4.13 compatiblity
+
+# 1.9.0 (11/21/2021)
+
+## Fixes
+
+- Ppx processes are now executed correctly (#513)
+
+## Breaking Change
+
+- ocamllsp drops support for `.merlin` files, and as a consequence no longer
+  depends on dot-merlin-reader. (#523)
+
+## Features
+
+- New code action to automatically remove values, types, opens (#502)
+
+# 1.8.3 (09/26/2021)
+
+- Fix debouncing of document updates. It was essentially completely broken in
+  all but the most trivial cases. (#509 fixes #504)
+
+- Fix completion when passing named and functional arguments (#512)
+
+# 1.8.2 (09/14/2021)
+
+- Disable experimental dune support. It was accidentally left enabled.
+
+# 1.8.1 (09/12/2021)
+
+- Update to latest merlin.
+
+# 1.8.0 (08/19/2021)
+
+## Fixes
+
+- Handle workspace change notifications. Previously, the server would only use
+  the set of workspaces given at startup to search for workspace symbols. After
+  this change, workspace folders that are added later will also be considered.
+  (#498)
+
+## Features
+
+- Add a new code action `Add missing rec keyword`, which is available when
+  adding a `rec` keyword can fix `Unbound value ...` error, e.g.,
+
+  ```ocaml
+  let fact n = if n = 0 then 1 else n * fact (n - 1)
+                                     (* ^^^^ Unbound value fact *)
+  ```
+
+  Adding `rec` to the definition of `fact` will fix the problem. The new code
+  action offers adding `rec`.
+
+- Use ocamlformat to properly format type snippets. This feature requires the
+  `ocamlformat-rpc` opam package to be installed. (#386)
+
+- Add completion support for polymorphic variants, when it is possible to pin
+  down the precise type. Examples (`<|>` stands for the cursor) when completion
+  will work (#473)
+
+  Function application:
+
+  ```
+  let foo (a: [`Alpha | `Beta]) = ()
+
+  foo `A<|>
+  ```
+
+  Type explicitly shown:
+
+  ```
+  let a : [`Alpha | `Beta] = `B<|>
+  ```
+
+  Note: this is actually a bug fix, since we were ignoring the backtick when
+  constructing the prefix for completion.
+
+- Parse merlin errors (best effort) into a more structured form. This allows
+  reporting all locations as "related information" (#475)
+
+- Add support for Merlin `Construct` command as completion suggestions, i.e.,
+  show complex expressions that could complete the typed hole. (#472)
+
+- Add a code action `Construct an expression` that is shown when the cursor is
+  at the end of the typed hole, i.e., `_|`, where `|` is the cursor. The code
+  action simply triggers the client (currently only VS Code is supported) to
+  show completion suggestions. (#472)
+
+- Change the formatting-on-save error notification to a warning notification
+  (#472)
+
+- Code action to qualify ("put module name in identifiers") and unqualify
+  ("remove module name from identifiers") module names in identifiers (#399)
+
+  Starting from:
+
+  ```ocaml
+  open Unix
+
+  let times = Unix.times ()
+  let f x = x.Unix.tms_stime, x.Unix.tms_utime
+  ```
+
+  Calling "remove module name from identifiers" with the cursor on the open
+  statement will produce:
+
+  ```ocaml
+  open Unix
+
+  let times = times ()
+  let f x = x.tms_stime, x.tms_utime
+  ```
+
+  Calling "put module name in identifiers" will restore:
+
+  ```ocaml
+  open Unix
+
+  let times = Unix.times ()
+  let f x = x.Unix.tms_stime, x.Unix.tms_utime
+  ```
+
+## Fixes
+
+- Do not show "random" documentation on hover
+
+  - fixed by [merlin#1364](https://github.com/ocaml/merlin/pull/1364)
+  - fixes duplicate:
+    - [ocaml-lsp#344](https://github.com/ocaml/ocaml-lsp/issues/344)
+    - [vscode-ocaml-platform#111](https://github.com/ocamllabs/vscode-ocaml-platform/issues/111)
+
+- Correctly rename a variable used as a named/optional argument (#478)
+
+- When reporting an error at the beginning of the file, use the first line not
+  the second (#489)
+
+# 1.7.0 (07/28/2021)
+
+## Features
+
+- Add sub-errors as "related" information in diagnostics (#457)
+
+- Add support for navigating to a symbol inside a workspace (#398)
+
+- Show typed holes as errors
+
+  Merlin has a concept of "typed holes" that are syntactically represented as `_`. Files
+  that incorporate typed holes are not considered valid OCaml, but Merlin and OCaml-LSP
+  support them. One example when such typed holes can occur is when on "destructs" a value,
+  e.g., destructing `(Some 1)` will generate code `match Some 1 with Some _ -> _ | None -> _`. While the first underscore is a valid "match-all"/wildcard pattern, the rest of
+  underscores are typed holes.
+
+# 1.6.1 (05/17/2020)
+
+## Fixes
+
+- Switch `verbosity` from 1 to 0. This is the same default that merlin uses.
+  The old value for verbosity (#433)
+
+- Get fresh diagnostics (warning and error messages) on a file save (#438)
+
+  Note: If you want the fresh diagnostics to take into account changes in other
+  files, you likely need to rebuild your project. An easy way to get automatic
+  rebuilds is to run `dune` in a watching mode, e.g.,[dune build --watch].
+
+# 1.6.0 (04/30/2020)
+
+## Features
+
+- Code action to annotate a value with its type (#397)
+
+## Fixes
+
+- Fix interface/implementation switching on Windows (#427)
+
+- Correctly parse project paths with spaces and other special characters that
+  must be escaped.
+
+- Print types with `-short-paths` even if the project wasn't built yet
+
+# 1.5.0 (03/18/2020)
+
+- Support 4.12 and drop support for all earlier versions
+
+- Update to the latest version of merlin
+
+# 1.4.1 (03/16/2020)
+
+## Fixes
+
+- Backport fixes from merlin (#382, #383)
+
+- Encode request & notification `params` in a list. This is required by the
+  spec. (#351)
+
+# 1.4.0 (12/17/2020)
+
+## Features
+
+- Support cancellation notifications when possible. (#323)
+
+- Implement signature help request for functions (#324)
+
+- Server LSP requests & notifications concurrently. Requests that require merlin
+  are still serialized. (#330)
+
+# 1.3.0 (11/23/2020)
+
+## Features
+
+- Code action to insert inferred module interface (#308)
+
+- Filter keywords by context (#307)
+
+# 1.2.0 (11/16/2020)
+
+## Features
+
+- Add keyword completion
+
+- Add go to declaration functionality to jump to a value's specification in a
+  .mli file (#294)
+
+## Fixes
+
+- #245: correctly use mutexes on OpenBSD (#264)
+
+- #268: Do not use vendored libraries when building the lsp package (#260)
+
+- #271: Clear diagnostics when files are closed
+
+- Disable non-prefix completion. There's no reliably way to trigger it and it
+  can be slow.
+
+# 1.1.0 (10/14/2020)
+
+## Features
+
+- Implement a command to switch between module interfaces and implementations
+  (#254)
+
+## Fixes
+
+- Do not crash on invalid positions (#248)
+
+- add missing record fields to list of completions (#253)
+
+- do not offer `destruct` as a code action in interface files (#255)
+
+# 1.0.0 (08/28/2020)
+
+- Initial Release

thirdparty/lsp/CODE_OF_CONDUCT.md

@@ -0,0 +1,13 @@
+# Code of Conduct
+
+This project has adopted the [OCaml Code of Conduct](https://github.com/ocaml/code-of-conduct/blob/main/CODE_OF_CONDUCT.md).
+
+# Enforcement
+
+This project follows the OCaml Code of Conduct
+[enforcement policy](https://github.com/ocaml/code-of-conduct/blob/main/CODE_OF_CONDUCT.md#enforcement).
+To report any violations, please contact:
+
+- Sonja Heinze <sonja [at] tarides [dot] com>
+- Ulysse Gérard <ulysse [at] tarides [dot] com>
+- Xavier Van de Woestyne <xavier [at] tarides [dot] com>

thirdparty/lsp/CONTRIBUTING.md

@@ -0,0 +1,124 @@
+# Contributing to ocaml-lsp
+
+OCaml-lsp is a community oriented open-source project and we encourage and value
+any kind of contribution. Thanks for taking the time to contribute 🐫 !
+
+## Code of Conduct
+
+OCaml-lsp  adheres to the OCaml Code of Conduct as stated in the [Code of Conduct
+document](CODE_OF_CONDUCT.md). By participating, you are expected to uphold this
+code. Please report unacceptable behavior either to local contacts (listed in
+[here](CODE_OF_CONDUCT.md)) or to someone listed in the upstream [OCaml Code of
+Conduct](CODE_OF_CONDUCT.md).
+
+## Documentation
+
+Much of the information relating to the repository, such as installation
+guidelines, how to set up a development environment and how to run unit tests,
+can be found in the project [README](README.md). And custom requests are
+documented in the
+[ocaml-lsp-server/docs/ocamllsp](ocaml-lsp-server/docs/ocamllsp) directory.
+
+Contributions to the documentation are welcome!
+
+
+## Question, bug reports and feature requests
+
+We rely on [Github's issue tracker](https://github.com/ocaml/ocaml-lsp/issues) for
+support questions, feature requests and bug reports.
+
+When reporting an issue, please include a precise reproduction in the bug report
+when that's possible, as it is a very useful tool to investigate. You should
+also check that you are using the latest version of OCaml-lsp and that a similar
+issue has not already been submitted.
+
+## Code contributions
+
+### Styleguides
+
+- **OCaml**: a large part of the code base is written in OCaml and the project
+  is configured to work with
+  [ocamlformat](https://ocaml.org/p/ocamlformat/latest) (version defined in the
+  [`.ocamlformat` file](.ocamlformat)).
+
+- **TypeScript**: TypeScript is used to describe certain end-to-end tests
+  (abbreviated as `e2e`) and the project uses the
+  [prettier](https://prettier.io/) formatter. But the TypeScript testsuite is
+  deprecated (we do not allow extending them anymore. Gradually we'll rewrite
+  them all to OCaml).
+
+Apart from that, the project tries to apply implicit conventions, at the
+decision of the maintainers. At the same time, it tries to follow certain naming
+conventions:
+
+- use of `t` manifest types in modules, when it makes sense;
+- conversion functions respecting the naming scheme: `to_xxx` or `of_xxx`;
+-  When you want to provide a conversion function for JSON, use the following
+   convention: `t_of_yojson` and `yojson_of_t` to fit properly with
+   `ppx_yojson_conv`.
+
+Changes unrelated to the issue addressed by a PR should be made in a separate
+PR. Additionally, formatting changes in parts of the code not concerned by a
+specific PR should be proposed in another PR.
+
+Ideally, any opened issue should be accompanied by a test with a reproduction.
+When working on a fix for an issue, the first commit should contain the test
+showing the issue. Following commits should fix the issue and update the test
+result accordingly.
+
+### Repository organization
+
+The repository exposes a number of separate libraries (some of which are
+internal) and vendor libraries (to reduce the dependencies required by the
+project). Here is a list of the libraries exposed by the project.
+
+#### ocaml-lsp-server
+
+Contains the concrete implementation of a protocol server language for OCaml. A
+frontend used in particular by [Visual Studio
+Code](https://github.com/ocamllabs/vscode-ocaml-platform), but also by code
+editors supporting LSP. The code lives mainly in the following directories:
+[ocaml-lsp-server/](ocaml-lsp-server/).
+
+In addition, the project exposes two sub-directories dedicated to [code
+actions](ocaml-lsp-server/src/code_actions) and [custom
+requests](https://github.com/ocaml/ocaml-lsp/tree/master/ocaml-lsp-server/src/custom_requests).
+
+In most cases, it is likely that the contributions will focus solely on this
+project.
+
+##### Warning
+
+For historical reasons, but also for development convenience, `ocaml-lsp-server`
+should not build logic based on `Typedtree` (which changes from version to
+version and migration logic is not provided by `lsp`, nor `ocaml-lsp-server` but
+by [Merlin](https://github.com/ocaml/merlin)). If a command, or a constant,
+relies on the `Typedtree`, it can be marked as _unstable_. Another approach,
+more robust, is to build a command in Merlin that handles the logic to ensure
+the migration is localized to a single project.
+
+#### lsp
+
+Implementation of the LSP protocol in OCaml. It is designed to be as portable as
+possible and does not make any assumptions about IO. This is the implementation
+of the plumbing required to describe the LSP protocol and is used by a concrete
+server (for example the OCaml server) to describe the exposition of the
+protocol. The code lives mainly in the following directories: [lsp/](lsp/) and
+[lsp-fiber/](lsp-fiber/).
+
+##### Warning
+
+The set of types forming the LSP protocol API is generated automatically by a
+[preprocessor](lsp/bin) based on the [protocol
+specification](https://microsoft.github.io/language-server-protocol/overviews/lsp/overview/).
+The pair of [types.ml](lsp/src/types.ml) and [types.mli](lsp/src/types.mli)
+files must be consciously modified manually (never modifying the parts marked as
+being generated by CINAPS, the preprocessor).
+
+
+#### jsonrpc
+
+Describes an implementation of the [JSON-RPC
+2.0](https://www.jsonrpc.org/specification) protocol, which is mainly used as a
+communication protocol for LSP. The code lives mainly in the following
+directories: [jsonrpc](jsonrpc/) and [jsonrpc-fiber/](jsonrpc-fiber/).

thirdparty/lsp/LICENSE.md

@@ -0,0 +1,16 @@
+ISC License
+
+Copyright (X) 2018-2019, the [ocaml-lsp
+contributors](https://github.com/ocaml/ocaml-lsp/graphs/contributors)
+
+Permission to use, copy, modify, and distribute this software for any
+purpose with or without fee is hereby granted, provided that the above
+copyright notice and this permission notice appear in all copies.
+
+THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

thirdparty/lsp/Makefile

@@ -0,0 +1,104 @@
+.DEFAULT_GOAL := all
+
+TEST_E2E_DIR = ocaml-lsp-server/test/e2e
+
+.PHONY: yarn-install
+yarn-install:
+	yarn install --frozen-lockfile
+
+-include Makefile.dev
+
+.PHONY: all
+all:
+	dune build @all
+
+# we don't use --with-test because it pulls test dependencies transitively in
+# practice this ends up pulling a lot of extra packages which invariably
+# results in a conflict
+.PHONY: install-test-deps
+install-test-deps:
+	opam install --yes cinaps 'ppx_expect>=v0.17.0' \
+		ocamlformat.$$(awk -F = '$$1 == "version" {print $$2}' .ocamlformat)
+
+.PHONY: dev
+dev: ## Setup a development environment
+	opam switch create --no-install . ocaml-base-compiler.4.14.0
+	opam install -y dune-release merlin ocamlformat utop ocaml-lsp-server
+	opam install --locked --deps-only --with-doc -y .
+	$(MAKE) install-test-deps
+
+.PHONY: install
+install: ## Install the packages on the system
+	dune build @install && dune install
+
+.PHONY: lock
+lock: ## Generate the lock files
+	opam lock -y .
+
+.PHONY: bench
+bench: ##
+	dune exec ocaml-lsp-server/bench/ocaml_lsp_bench.exe --profile bench
+
+.PHONY: test-ocaml
+test-ocaml: ## Run the unit tests
+	dune build @lsp/test/runtest @lsp-fiber/runtest @jsonrpc-fiber/runtest @ocaml-lsp-server/runtest
+
+.PHONY: promote
+promote:
+	dune promote
+
+.PHONY: check
+check:
+	dune build @check
+
+.PHONY: test-e2e
+test-e2e: yarn-install
+	dune build @install && dune exec -- ocaml-lsp-server/test/run_test_e2e.exe
+
+.PHONY: promote-e2e
+promote-e2e:
+	dune build @install && cd $(TEST_E2E_DIR) && dune exec -- yarn run promote
+
+.PHONY: test
+test: test-ocaml test-e2e
+
+.PHONY: clean
+clean: ## Clean build artifacts and other generated files
+	dune clean
+
+.PHONY: fmt
+fmt: ## Format the codebase with ocamlformat
+	dune build @fmt --auto-promote
+
+.PHONY: watch
+watch: ## Watch for the filesystem and rebuild on every change
+	dune build --watch
+
+.PHONY: utop
+utop: ## Run a REPL and link with the project's libraries
+	dune utop . -- -implicit-bindings
+
+.PHONY: release
+release: ## Release on Opam
+	dune-release distrib --skip-build --skip-lint --skip-tests --include-submodules
+	# See https://github.com/ocamllabs/dune-release/issues/206
+	DUNE_RELEASE_DELEGATE=github-dune-release-delegate dune-release publish distrib --verbose
+	dune-release opam pkg
+	dune-release opam submit
+
+.PHONY: nix-tests
+nix-tests: yarn-install
+	make test
+
+.PHONY: nix-fmt
+nix-fmt: yarn-install
+	dune build @fmt --auto-promote
+
+.PHONY: coverage-deps
+coverage-deps:
+	opam install -y bisect_ppx
+
+.PHONY: test-coverage
+test-coverage:
+	dune build --instrument-with bisect_ppx --force @lsp/test/runtest @lsp-fiber/runtest @jsonrpc-fiber/runtest @ocaml-lsp-server/runtest
+	bisect-ppx-report send-to Coveralls

thirdparty/lsp/README.md

@@ -0,0 +1,423 @@
+# OCaml-LSP <!-- omit from toc -->
+<!-- TOC is updated automatically by "Markdown All in One" vscode extension -->
+
+[![Build][build-badge]][build]
+[![Coverage Status][coverall-badge]][coverall]
+
+[build-badge]: https://github.com/ocaml/ocaml-lsp/actions/workflows/build-and-test.yml/badge.svg
+[build]: https://github.com/ocaml/ocaml-lsp/actions
+[coverall-badge]: https://coveralls.io/repos/github/ocaml/ocaml-lsp/badge.svg?branch=master
+[coverall]: https://coveralls.io/github/ocaml/ocaml-lsp?branch=master
+
+OCaml-LSP is a language server for OCaml that implements [Language Server
+Protocol](https://microsoft.github.io/language-server-protocol/) (LSP).
+
+> If you use Visual Studio Code, see OCaml Platform extension
+> [page](https://github.com/ocamllabs/vscode-ocaml-platform) for detailed
+> instructions on setting up your editor for OCaml development with OCaml-LSP:
+> what packages need to be installed, how to configure your project and get
+> most out of the OCaml editor support, and how to report and debug problems.
+
+- [Installation](#installation)
+  - [Installing with package managers](#installing-with-package-managers)
+    - [Opam](#opam)
+    - [Esy](#esy)
+  - [Installing from sources](#installing-from-sources)
+  - [Additional package installations](#additional-package-installations)
+- [Usage](#usage)
+  - [Integration with Dune RPC](#integration-with-dune-rpc)
+  - [Merlin configuration (advanced)](#merlin-configuration-advanced)
+- [Features](#features)
+  - [Semantic highlighting](#semantic-highlighting)
+  - [LSP Extensions](#lsp-extensions)
+  - [Unusual features](#unusual-features)
+- [Debugging](#debugging)
+- [Contributing to project](#contributing-to-project)
+  - [Changelog](#changelog)
+- [Tests](#tests)
+- [Relationship to Other Tools](#relationship-to-other-tools)
+- [History](#history)
+- [Comparison to other LSP Servers for OCaml](#comparison-to-other-lsp-servers-for-ocaml)
+
+## Installation
+
+Below we show how to install OCaml-LSP using opam, esy, and from sources. OCaml-LSP comes in a package called `ocaml-lsp-server` but the installed program (i.e., binary) is called `ocamllsp`.
+
+### Installing with package managers
+
+#### Opam
+
+To install the language server in the currently used opam [switch](https://opam.ocaml.org/doc/Manual.html#Switches):
+
+```sh
+$ opam install ocaml-lsp-server
+```
+
+_Note:_ you will need to install `ocaml-lsp-server` in every switch where you
+would like to use it.
+
+#### Esy
+
+To add the language server to an esy project, run in terminal:
+
+```sh
+$ esy add @opam/ocaml-lsp-server
+```
+
+### Installing from sources
+
+This project uses submodules to handle dependencies. This is done so that users
+who install `ocaml-lsp-server` into their sandbox will not share dependency
+constraints on the same packages that `ocaml-lsp-server` is using.
+
+```sh
+$ git clone --recurse-submodules http://github.com/ocaml/ocaml-lsp.git
+$ cd ocaml-lsp
+$ make install
+```
+
+### Additional package installations
+
+- Install [ocamlformat](https://github.com/ocaml-ppx/ocamlformat#installation)
+  package if you want source file formatting support.
+
+  Note: To have source file formatting support in your project, there needs to
+  be an `.ocamlformat` file present in your project's root directory.
+
+- OCaml-LSP also uses a program called `ocamlformat-rpc` to format code that is
+  either generated or displayed by OCaml-LSP, e.g., when you hover over a module
+  identifier, you can see its typed nicely formatted. This program comes with
+  `ocamlformat` (version > 0.21.0). Previously, it was a standalone package.
+
+## Usage
+
+Usually, your code editor, or some extension/plugin that you install on it, is
+responsible for launching `ocamllsp`.
+
+Important: OCaml Language Server has its information about the files from the
+last time your built your project. We recommend using the Dune build system and
+running it in "watch" mode to always have correctly functioning OCaml-LSP, e.g.,
+`dune build --watch`.
+
+### Integration with Dune RPC
+
+> since OCaml-LSP 1.11.0
+
+OCaml-LSP can communicate with Dune's RPC system to offer some interesting
+features. User can launch Dune's RPC system by running Dune in watch mode.
+OCaml-LSP will *not* launch Dune's RPC for you. But OCaml-LSP will see if there
+is an RPC running and will communicate with it automatically.
+
+There are various interesting features and caveats:
+
+1. Dune's RPC enables new kinds of diagnostics (i.e., warnings and errors) to be
+   shown in the editor, e.g., mismatching interface and implementation files.
+   You need to save the file to refresh such diagnostics because Dune doesn't
+   see unsaved files; otherwise, you may see stale (no longer correct) warnings
+   or errors. OCaml-LSP updates diagnostics after each build is complete in
+   watch mode.
+
+2. Dune file promotion support. If you, for example, use `ppx_expect` and have
+   failing tests, you will get a diagnostic when Dune reports that your file can
+   be promoted. You can promote your file using the code action `Promote`.
+
+### Merlin configuration (advanced)
+
+If you would like OCaml-LSP to respect your `.merlin` files, OCaml-LSP needs to
+be invoked with `--fallback-read-dot-merlin` argument passed to it and you must
+have the `dot-merlin-reader` package installed.
+
+## Features
+
+<!-- TODO:
+  this is quite a large list (which becomes even larger since it's missing some requests), which is not necessarily of big interest to users.
+
+  We should consider:
+  1. Moving it to the bottom
+  2. Converting it into a table
+
+     | Description      | Method                  | OCaml | Reason | Dune | Menhir | .ocamlformat | ...
+     | Auto-completion  | textDocument/completion |   x   |    x   |   o  |   o    |      o       | ...
+
+  3. (not sure how) Generate the table automatically because, otherwise, it's outdated frequently.
+-->
+
+The server supports the following LSP requests (inexhaustive list):
+
+- [x] `textDocument/completion`
+- [x] `completionItem/resolve`
+- [x] `textdocument/hover`
+- [ ] `textDocument/signatureHelp`
+- [x] `textDocument/declaration`
+- [x] `textDocument/definition`
+- [x] `textDocument/typeDefinition`
+- [ ] `textDocument/implementation`
+- [x] `textDocument/codeLens`
+- [x] `textDocument/documentHighlight`
+- [x] `textDocument/documentSymbol`
+- [x] `textDocument/references`
+- [ ] `textDocument/documentColor`
+- [ ] `textDocument/colorPresentation`
+- [x] `textDocument/formatting`
+- [ ] `textDocument/rangeFormatting`
+- [ ] `textDocument/onTypeFormatting`
+- [x] `textDocument/prepareRename`
+- [x] `textDocument/foldingRange`
+- [x] `textDocument/selectionRange`
+- [x] `workspace/didChangeConfiguration`
+- [x] `workspace/symbol`
+
+Note that degrees of support for each LSP request are varying.
+
+## Configuration
+
+[Read more about configurations supported by ocamllsp](./ocaml-lsp-server/docs/ocamllsp/config.md)
+
+### Semantic highlighting
+
+> since OCaml-LSP 1.15.0 (since version `1.15.0-4.14` for OCaml 4, `1.15.0-5.0` for OCaml 5)
+
+Semantic highlighting support is enabled by default.
+
+> since OCaml-LSP 1.14.0
+
+OCaml-LSP implements experimental semantic highlighting support (also known as
+semantic tokens support). The support can be activated by passing an environment
+variable to OCaml-LSP:
+
+- To enable non-incremental (expectedly slower but more stable) version, pass
+  `OCAMLLSP_SEMANTIC_HIGHLIGHTING=full` environment variable to OCaml-LSP.
+
+- To enable incremental (potentially faster but more error-prone, at least on VS
+  Code) version, pass `OCAMLLSP_SEMANTIC_HIGHLIGHTING=full/delta` to OCaml-LSP.
+
+Tip (for VS Code OCaml Platform users): You can use `ocaml.server.extraEnv`
+setting in VS Code to pass various environment variables to OCaml-LSP.
+
+```json
+{
+    "ocaml.server.extraEnv": {
+        "OCAMLLSP_SEMANTIC_HIGHLIGHTING": "full"
+    },
+}
+```
+
+### LSP Extensions
+
+The server also supports a number of OCaml specific extensions to the protocol:
+- [Switch to implementation/interface](ocaml-lsp-server/docs/ocamllsp/switchImplIntf-spec.md)
+- [Infer interface](ocaml-lsp-server/docs/ocamllsp/inferIntf-spec.md)
+- [Locate typed holes](ocaml-lsp-server/docs/ocamllsp/typedHoles-spec.md)
+- [Find wrapping AST node](ocaml-lsp-server/docs/ocamllsp/wrappingAstNode-spec.md)
+
+Note that editor support for these extensions varies. In general, the OCaml Platform extension for Visual Studio Code will have the best support.
+
+### Unusual features
+
+#### Destructing a value <!-- omit in toc -->
+
+> since OCaml-LSP 1.0.0
+
+OCaml-LSP has a code action that allows to generate an exhaustive pattern
+matching for values. For example, placing a cursor near a value `(Some 10)|`
+where `|` is your cursor, OCaml-LSP will offer a code action "Destruct", which
+replaces `(Some 10)` with `(match Some with | None -> _ | Some _ -> _)`.
+Importantly, one can only destruct a value if OCaml-LSP can infer the value's
+precise type. The value can be type-annotated, e.g., if it's a function argument
+with polymorphic (or yet unknown) type in this context. In the code snippet
+below, we type-annotate the function parameter `v` because when we type `let f v
+= v|`, the type of `v` is polymorphic, so we can't destruct it.
+
+You can also usually destruct the value by placing the cursor on the wildcard
+(`_`) pattern in a pattern-match. For example,
+
+```ocaml
+type t = A | B of string option
+
+let f (v : t) = match v with | A -> _ | B _| -> _
+```
+
+invoking destruct near the cursor (`|`) in the snippet above, you get
+
+```ocaml
+type t = A | B of string option
+
+let f (v : t) = match v with | A -> _ | B (None) | B (Some _) -> _
+```
+
+Importantly, note the underscores in place of expressions in each branch of the
+pattern match above. The underscores that occur in place of expressions are
+called "typed holes" - a concept explained below.
+
+Tip (formatting): generated code may not be greatly formatted. If your project
+uses a formatter such as OCamlFormat, you can run formatting and get a
+well-formatted document (OCamlFormat supports typed holes formatting).
+
+Tip (for VS Code OCaml Platform users): You can destruct a value using a keybinding
+<kbd>Alt</kbd>+<kbd>D</kbd> or on MacOS <kbd>Option</kbd>+<kbd>D</kbd>
+
+#### Typed holes <!-- omit in toc -->
+
+> since OCaml-LSP 1.8.0
+
+OCaml-LSP has a concept of a "typed hole" syntactically represented as `_`
+(underscore). A typed hole represents a well-typed "substitute" for an
+expression. OCaml-LSP considers these underscores that occur in place of
+expressions as a valid well-typed OCaml program: `let foo : int = _` (the typed
+hole has type `int` here) or `let bar = _ 10` (the hole has type `int -> 'a`).
+One can use such holes during development as temporary substitutes for
+expressions and "plug" the holes later with appropriate expressions.
+
+Note, files that incorporate typed holes are *not* considered valid OCaml by the
+OCaml compiler and, hence, cannot be compiled.
+
+Also, an underscore occurring in place of a pattern (for example `let _ = 10`)
+should not be confused with a typed hole that occurs in place of an expression,
+e.g., `let a = _`.
+
+#### Constructing values by type (experimental) <!-- omit in toc -->
+
+> since OCaml-LSP 1.8.0
+
+OCaml-LSP can "construct" expressions based on the type required and offer them
+during auto-completion. For example, typing `_` (typed hole) in the snippet
+below will trigger auto-completion (`|` is your cursor):
+
+```ocaml
+(* file foo.ml *)
+type t = A | B of string option
+
+(* file bar.ml *)
+let v : Foo.t = _|
+```
+
+The auto-completion offers completions `Foo.A` and `Foo.B _`. You can further
+construct values by placing the cursor as such: `Foo.B _|` and triggering code
+action "Construct an expression" which offers completions `None` and `Some _`.
+Trigger the same code action in `Some _|` will offer `""` - one of the possible
+expressions to replace the typed hole with.
+
+Constructing a value is thus triggered either by typing `_` in place of an
+expression or trigger the code action "Construct an Expression". Also, the type
+of the value needs to be non-polymorphic to construct a meaningful value.
+
+Tip (for VS Code OCaml Platform users): You can construct a value using a keybinding
+<kbd>Alt</kbd>+<kbd>C</kbd> or on MacOS <kbd>Option</kbd>+<kbd>C</kbd>
+
+#### Syntax Documentation
+
+> since OCaml-LSP 1.18.0
+
+OCaml-LSP can display documentation about the node under the cursor when
+the user hovers over some OCaml code. For example, hovering over the code
+snippet below will display some information about what the syntax
+is:
+
+```ocaml
+type point = {x: int; y: int}
+```
+Hovering over the above will
+display:
+```
+ocaml type point = { x : int; y : int }
+syntax Record type:
+Allows you to define variants with a fixed set of fields, and all of the
+constructors for a record variant type must have the same fields. See
+Manual
+```
+The documentation is gotten from the Merlin engine which receives
+the nodes under the cursor and infers what the syntax may be about, and
+displays the required information along with links to the manual for further
+reading.
+
+Syntax Documentation is an optional feature and can be activated by
+using the LSP config system with the key called `syntaxDocumentation` and can
+be enabled via setting it to `{ enable: true }`.
+
+## Debugging
+
+If you use Visual Studio Code, please see OCaml Platform extension
+[page](https://github.com/ocamllabs/vscode-ocaml-platform) for a detailed guide
+on how to report and debug problems.
+
+If you use another code editor and use OCaml-LSP, you should be able to set the
+server trace to `verbose` using your editor's LSP client and watch the trace
+for errors such as logged exceptions.
+
+## Contributing to project
+
+```bash
+# clone repo with submodules
+git clone --recursive git@github.com:ocaml/ocaml-lsp.git
+
+cd ocaml-lsp
+
+# if you already cloned, pull submodules
+git submodule update --init --recursive
+
+# create local switch (or use global one)
+opam switch --yes create .
+
+# don't forget to set your environment to use the local switch
+eval $(opam env)
+
+# install dependencies
+make install-test-deps
+
+# build
+make all
+
+# the ocamllsp executable can be found at _build/default/ocaml-lsp-server/bin/main.exe
+```
+
+### Changelog
+
+User-visible changes should come with an entry in the changelog under the appropriate part of
+the **unreleased** section. PR that doesn't provide an entry will fail CI check. This behavior
+can be overridden by using the "no changelog" label, which is used for changes that are not user-visible.
+
+## Tests
+
+To run tests execute:
+
+```sh
+$ make test
+```
+
+Note that tests require [Node.js](https://nodejs.org/en/) and
+[Yarn](https://yarnpkg.com/lang/en/) installed.
+
+## Relationship to Other Tools
+
+The lsp server uses merlin under the hood, but users are not required to have
+merlin installed. We vendor merlin because we currently heavily depend on some
+implementation details of merlin that make it infeasible to upgrade the lsp
+server and merlin independently.
+
+## History
+
+The implementation of the lsp protocol itself was taken from
+[facebook's hack](https://github.com/facebook/hhvm/blob/master/hphp/hack/src/utils/lsp/lsp.mli)
+
+Previously, this lsp server was a part of merlin, until it was realized that
+the lsp protocol covers a wider scope than merlin.
+
+## Comparison to other LSP Servers for OCaml
+
+Note that the comparisons below make no claims of being objective and may be
+entirely out of
+date. Also, both servers seem deprecated.
+
+- [reason-language-server](https://github.com/jaredly/reason-language-server)
+  This server supports
+  [bucklescript](https://github.com/BuckleScript/bucklescript) &
+  [reason](https://github.com/facebook/reason). However, this project does not
+  use merlin which means that it supports fewer versions of OCaml and offers less
+  "smart" functionality - especially in the face of sources that do not yet
+  compile.
+
+- [ocaml-language-server](https://github.com/ocaml-lsp/ocaml-language-server)
+  This project is extremely similar in the functionality it provides because it
+  also reuses merlin on the backend. The essential difference is that this
+  project is written in typescript, while our server is in OCaml. We feel that
+  it's best to use OCaml to maximize the contributor pool.

thirdparty/lsp/biome.json

@@ -0,0 +1,23 @@
+{
+  "$schema": "node_modules/@biomejs/biome/configuration_schema.json",
+  "formatter": {
+    "enabled": true,
+    "ignore": ["lsp/bin/metamodel/metaModel.json", "package.json"],
+    "useEditorconfig": true
+  },
+  "linter": {
+    "enabled": true,
+    "ignore": ["ocaml-lsp-server/test/e2e/**"],
+    "rules": {
+      "recommended": true
+    }
+  },
+  "organizeImports": {
+    "enabled": true
+  },
+  "vcs": {
+    "clientKind": "git",
+    "enabled": true,
+    "useIgnoreFile": true
+  }
+}

thirdparty/lsp/dune

@@ -0,0 +1,13 @@
+(vendored_dirs vendor)
+
+(data_only_dirs submodules)
+
+(rule
+ (copy lsp.opam.template jsonrpc.opam.template))
+
+(rule
+ (copy lsp.opam.template ocaml-lsp-server.opam.template))
+
+(env
+ (_
+  (flags :standard -alert -unstable -w -58)))

thirdparty/lsp/dune-project

@@ -0,0 +1,82 @@
+(lang dune 3.0)
+(using cinaps 1.0)
+(name lsp)
+
+(implicit_transitive_deps false)
+
+(license ISC)
+(maintainers "Rudi Grinberg <me@rgrinberg.com>")
+(authors
+ "Andrey Popp <8mayday@gmail.com>"
+ "Rusty Key <iam@stfoo.ru>"
+ "Louis Roché <louis@louisroche.net>"
+ "Oleksiy Golovko <alexei.golovko@gmail.com>"
+ "Rudi Grinberg <me@rgrinberg.com>"
+ "Sacha Ayoun <sachaayoun@gmail.com>"
+ "cannorin <cannorin@gmail.com>"
+ "Ulugbek Abdullaev <ulugbekna@gmail.com>"
+ "Thibaut Mattio <thibaut.mattio@gmail.com>"
+ "Max Lantas <mnxndev@outlook.com>")
+
+(source (github ocaml/ocaml-lsp))
+
+(generate_opam_files true)
+
+(package
+ (name lsp)
+ (synopsis "LSP protocol implementation in OCaml")
+ (description "
+Implementation of the LSP protocol in OCaml. It is designed to be as portable as
+possible and does not make any assumptions about IO.
+")
+ (depends
+  (jsonrpc (= :version))
+  yojson
+  (ppx_yojson_conv_lib (>= "v0.14"))
+  (cinaps :with-test)
+  (ppx_expect (and (>= v0.17.0) :with-test))
+  (uutf (>= 1.0.2))
+  (odoc :with-doc)
+  (ocaml (>= 4.14))
+  (ppx_yojson_conv :with-dev-setup)))
+
+(package
+ (name ocaml-lsp-server)
+ (synopsis "LSP Server for OCaml")
+ (description "An LSP server for OCaml.")
+ (depends
+  yojson
+  (base (>= v0.16.0))
+  (lsp (= :version))
+  (jsonrpc (= :version))
+  (re (>= 1.5.0))
+  (ppx_yojson_conv_lib (>= "v0.14"))
+  (dune-rpc (>= 3.4.0))
+  (chrome-trace (>= 3.3.0))
+  dyn
+  stdune
+  (fiber (and (>= 3.1.1) (< 4.0.0)))
+  (ocaml (and (>= 5.3) (< 5.4)))
+  xdg
+  ordering
+  dune-build-info
+  spawn
+  astring
+  camlp-streams
+  (ppx_expect (and (>= v0.17.0) :with-test))
+  (ocamlformat (and :with-test (= 0.27.0)))
+  (ocamlc-loc (>= 3.7.0))
+  (pp (>= 1.1.2))
+  (csexp (>= 1.5))
+  (ocamlformat-rpc-lib (>= 0.21.0))
+  (odoc :with-doc)
+  (merlin-lib (and (>= 5.4) (< 6.0)))
+  (ppx_yojson_conv :with-dev-setup)))
+
+(package
+ (name jsonrpc)
+ (synopsis "Jsonrpc protocol implemenation")
+ (description "See https://www.jsonrpc.org/specification")
+ (depends
+  (ocaml (>= 4.08))
+  (odoc :with-doc)))

thirdparty/lsp/fiber-test/dune

@@ -0,0 +1,3 @@
+(library
+ (name fiber_test)
+ (libraries fiber stdune dyn pp))

thirdparty/lsp/fiber-test/fiber_test.ml

@@ -0,0 +1,52 @@
+open Stdune
+
+let print pp = Format.printf "%a@." Pp.to_fmt pp
+let print_dyn dyn = print (Dyn.pp dyn)
+
+module Scheduler : sig
+  type t
+
+  exception Never
+
+  val create : unit -> t
+  val run : t -> 'a Fiber.t -> 'a
+end = struct
+  type t = unit Fiber.Ivar.t Queue.t
+
+  let t_var = Fiber.Var.create ()
+  let create () = Queue.create ()
+
+  exception Never
+
+  let run t fiber =
+    let fiber = Fiber.Var.set t_var t (fun () -> fiber) in
+    Fiber.run fiber ~iter:(fun () ->
+      let next =
+        match Queue.pop t with
+        | None -> raise Never
+        | Some e -> Fiber.Fill (e, ())
+      in
+      Nonempty_list.[ next ])
+  ;;
+end
+
+let test ?(expect_never = false) to_dyn f =
+  let never_raised = ref false in
+  let f =
+    let on_error exn =
+      Format.eprintf "%a@." Exn_with_backtrace.pp_uncaught exn;
+      Exn_with_backtrace.reraise exn
+    in
+    Fiber.with_error_handler f ~on_error
+  in
+  (try Scheduler.run (Scheduler.create ()) f |> to_dyn |> print_dyn with
+   | Scheduler.Never -> never_raised := true);
+  match !never_raised, expect_never with
+  | false, false ->
+    (* We don't raise in this case b/c we assume something else is being
+       tested *)
+    ()
+  | true, true -> print_endline "[PASS] Never raised as expected"
+  | false, true -> print_endline "[FAIL] expected Never to be raised but it wasn't"
+  | true, false -> print_endline "[FAIL] unexpected Never raised"
+;;

thirdparty/lsp/fiber-test/fiber_test.mli

@@ -0,0 +1 @@
+val test : ?expect_never:bool -> ('a -> Dyn.t) -> (unit -> 'a Fiber.t) -> unit

thirdparty/lsp/flake.lock

@@ -0,0 +1,115 @@
+{
+  "nodes": {
+    "flake-utils": {
+      "inputs": {
+        "systems": "systems"
+      },
+      "locked": {
+        "lastModified": 1731533236,
+        "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=",
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b",
+        "type": "github"
+      },
+      "original": {
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "type": "github"
+      }
+    },
+    "merlin5_1": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1727427299,
+        "narHash": "sha256-P9+3BPBWrulS/1r03CqMdicFcgEcLK1Gy7pCAcYt3n4=",
+        "owner": "ocaml",
+        "repo": "merlin",
+        "rev": "650a7865bc37a646250f7c52fa6644d9d4a5218b",
+        "type": "github"
+      },
+      "original": {
+        "owner": "ocaml",
+        "ref": "501",
+        "repo": "merlin",
+        "type": "github"
+      }
+    },
+    "merlin5_2": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1736508467,
+        "narHash": "sha256-ZJFtPreWenLlXDokh3dOR+b3LRuZJgs9+6r+tEx9/Vo=",
+        "owner": "ocaml",
+        "repo": "merlin",
+        "rev": "9dcffb9e998703f5f5d6e7c575c30cd822cea210",
+        "type": "github"
+      },
+      "original": {
+        "owner": "ocaml",
+        "ref": "main",
+        "repo": "merlin",
+        "type": "github"
+      }
+    },
+    "nixpkgs": {
+      "inputs": {
+        "nixpkgs": "nixpkgs_2"
+      },
+      "locked": {
+        "lastModified": 1736449896,
+        "narHash": "sha256-Ct6RqUtqIfazkg1X4o2FXWuYpw0A+OJsd3cFGtmXaqk=",
+        "owner": "nix-ocaml",
+        "repo": "nix-overlays",
+        "rev": "be7cfa6043ed31b17e4b86769c05825c62e55829",
+        "type": "github"
+      },
+      "original": {
+        "owner": "nix-ocaml",
+        "repo": "nix-overlays",
+        "type": "github"
+      }
+    },
+    "nixpkgs_2": {
+      "locked": {
+        "lastModified": 1736384491,
+        "narHash": "sha256-h0hPzFp7iVhCqzBx+kJGdO/KmG8AkYRJ0jKxQ6+diug=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "8e97141d59b87e2bf254cd0920be29955d45a698",
+        "type": "github"
+      },
+      "original": {
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "8e97141d59b87e2bf254cd0920be29955d45a698",
+        "type": "github"
+      }
+    },
+    "root": {
+      "inputs": {
+        "flake-utils": "flake-utils",
+        "merlin5_1": "merlin5_1",
+        "merlin5_2": "merlin5_2",
+        "nixpkgs": "nixpkgs"
+      }
+    },
+    "systems": {
+      "locked": {
+        "lastModified": 1681028828,
+        "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
+        "owner": "nix-systems",
+        "repo": "default",
+        "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
+        "type": "github"
+      },
+      "original": {
+        "owner": "nix-systems",
+        "repo": "default",
+        "type": "github"
+      }
+    }
+  },
+  "root": "root",
+  "version": 7
+}

thirdparty/lsp/flake.nix

@@ -0,0 +1,184 @@
+{
+  inputs = {
+    flake-utils.url = "github:numtide/flake-utils";
+    nixpkgs.url = "github:nix-ocaml/nix-overlays";
+    merlin5_2 = {
+      url = "github:ocaml/merlin/main";
+      flake = false;
+    };
+    merlin5_1 = {
+      url = "github:ocaml/merlin/501";
+      flake = false;
+    };
+  };
+
+  outputs = { self, flake-utils, nixpkgs, ... }@inputs:
+    let
+      package = "ocaml-lsp-server";
+      ocamlformat = pkgs: pkgs.ocamlformat_0_26_2;
+      basePackage = {
+        duneVersion = "3";
+        version = "n/a";
+        src = ./.;
+        doCheck = true;
+      };
+      overlay = merlin: final: prev: {
+        ocaml-lsp = prev.ocaml-lsp.overrideAttrs (_: {
+          # Do not add share/nix-support, so that dependencies from
+          # the scope don't leak into dependent derivations
+          doNixSupport = false;
+        });
+        dune-release =
+          prev.dune-release.overrideAttrs (_: { doCheck = false; });
+        ocamlPackages = prev.ocamlPackages.overrideScope' (oself: osuper:
+          let
+            fixPreBuild = o: {
+              propagatedBuildInputs = o.propagatedBuildInputs ++ [ oself.pp ];
+              preBuild = ''
+                rm -r vendor/csexp vendor/pp
+              '';
+            };
+          in {
+            # TODO remove these hacks eventually
+            dyn = osuper.dyn.overrideAttrs fixPreBuild;
+            dune-private-libs =
+              osuper.dune-private-libs.overrideAttrs fixPreBuild;
+            dune-glob = osuper.dune-glob.overrideAttrs fixPreBuild;
+            dune-action-plugin =
+              osuper.dune-action-plugin.overrideAttrs fixPreBuild;
+            dune-rpc = osuper.dune-rpc.overrideAttrs fixPreBuild;
+            stdune = osuper.stdune.overrideAttrs fixPreBuild;
+            merlin-lib = osuper.merlin-lib.overrideAttrs (o: { src = merlin; });
+          });
+      };
+      ocamlVersionOverlay =
+        (ocaml: self: super: { ocamlPackages = ocaml super.ocaml-ng; });
+      makeLocalPackages = pkgs:
+        let buildDunePackage = pkgs.ocamlPackages.buildDunePackage;
+        in rec {
+          jsonrpc = buildDunePackage (basePackage // {
+            pname = "jsonrpc";
+            doCheck = false;
+            propagatedBuildInputs = with pkgs.ocamlPackages; [ ];
+          });
+
+          lsp = buildDunePackage (basePackage // {
+            pname = "lsp";
+            doCheck = false;
+            propagatedBuildInputs = with pkgs.ocamlPackages; [
+              jsonrpc
+              yojson
+              ppx_yojson_conv_lib
+              uutf
+            ];
+            checkInputs = let p = pkgs.ocamlPackages;
+            in [
+              p.stdune
+              p.cinaps
+              p.ppx_expect
+              p.ppx_yojson_conv
+              (ocamlformat pkgs)
+            ];
+          });
+
+          ocaml-lsp = with pkgs.ocamlPackages;
+            buildDunePackage (basePackage // {
+              pname = package;
+              doCheck = false;
+              checkInputs = let p = pkgs.ocamlPackages;
+              in [
+                p.ppx_expect
+                p.ppx_yojson_conv
+                (ocamlformat pkgs)
+                pkgs.yarn
+              ];
+              buildInputs = [
+                jsonrpc
+                lsp
+                ocamlc-loc
+                astring
+                camlp-streams
+                dune-build-info
+                re
+                dune-rpc
+                chrome-trace
+                dyn
+                fiber
+                xdg
+                ordering
+                spawn
+                csexp
+                ocamlformat-rpc-lib
+                stdune
+                yojson
+                ppx_yojson_conv_lib
+                merlin-lib
+                base
+              ];
+              propagatedBuildInputs = [ ];
+              buildPhase = ''
+                runHook preBuild
+                dune build ${package}.install --release ''${enableParallelBuilding:+-j $NIX_BUILD_CORES}
+                runHook postBuild
+              '';
+              meta = { mainProgram = "ocamllsp"; };
+            });
+        };
+    in {
+      overlays.default = (final: prev: {
+        ocamlPackages = prev.ocamlPackages.overrideScope
+          (oself: osuper: with oself; makeLocalPackages final);
+      });
+    } // (flake-utils.lib.eachDefaultSystem (system:
+      let
+        pkgsWithoutOverlays = (import nixpkgs { inherit system; });
+        makeNixpkgs = ocaml: merlin:
+          import nixpkgs {
+            overlays = [ (ocamlVersionOverlay ocaml) (overlay merlin) ];
+            inherit system;
+          };
+        pkgs_5_1 =
+          makeNixpkgs (ocaml: ocaml.ocamlPackages_5_1) inputs.merlin5_1;
+        pkgs_5_2 =
+          makeNixpkgs (ocaml: ocaml.ocamlPackages_5_2) inputs.merlin5_2;
+        localPackages_5_1 = makeLocalPackages pkgs_5_1;
+        localPackages_5_2 = makeLocalPackages pkgs_5_2;
+        devShell = localPackages: nixpkgs:
+          nixpkgs.mkShell {
+            buildInputs = [ nixpkgs.ocamlPackages.utop ];
+            inputsFrom =
+              builtins.map (x: x.overrideAttrs (p: n: { doCheck = true; }))
+              (builtins.attrValues localPackages);
+          };
+      in {
+        packages = (localPackages_5_2 // {
+          default = localPackages_5_2.ocaml-lsp;
+          ocaml_5_1 = localPackages_5_1;
+        });
+
+        devShells = {
+          default = devShell localPackages_5_2 pkgs_5_2;
+
+          ocaml5_1 = devShell localPackages_5_1 pkgs_5_1;
+
+          release = pkgsWithoutOverlays.mkShell {
+            buildInputs = [ pkgsWithoutOverlays.dune-release ];
+          };
+
+          fmt = pkgsWithoutOverlays.mkShell {
+            buildInputs = [
+              # TODO: get rid of ocaml once dune get format without ocaml being
+              # present
+              pkgsWithoutOverlays.ocaml
+              (ocamlformat pkgsWithoutOverlays)
+              pkgsWithoutOverlays.yarn
+              pkgsWithoutOverlays.dune_3
+            ];
+          };
+
+          check = pkgs_5_2.mkShell {
+            inputsFrom = builtins.attrValues localPackages_5_2;
+          };
+        };
+      }));
+}

thirdparty/lsp/jsonrpc-fiber/src/dune

@@ -0,0 +1,5 @@
+(library
+ (name jsonrpc_fiber)
+ (libraries fiber dyn jsonrpc ppx_yojson_conv_lib stdune yojson)
+ (instrumentation
+  (backend bisect_ppx)))

thirdparty/lsp/jsonrpc-fiber/src/import.ml

@@ -0,0 +1,85 @@
+module List = ListLabels
+
+include struct
+  (* TODO remove stdune dependence *)
+
+  open Stdune
+  module Code_error = Code_error
+  module Exn_with_backtrace = Exn_with_backtrace
+end
+
+include struct
+  open Jsonrpc
+  module Id = Id
+  module Response = Response
+  module Request = Request
+  module Notification = Notification
+  module Packet = Packet
+end
+
+module Json = struct
+  type t = Ppx_yojson_conv_lib.Yojson.Safe.t
+
+  let to_pretty_string (t : t) = Yojson.Safe.pretty_to_string ~std:false t
+  let error = Ppx_yojson_conv_lib.Yojson_conv.of_yojson_error
+  let pp ppf (t : t) = Yojson.Safe.pretty_print ppf t
+
+  let rec of_dyn (t : Dyn.t) : t =
+    match t with
+    | Opaque -> `String "<opaque>"
+    | Unit -> `String "()"
+    | Int i -> `Int i
+    | Int32 i -> `Int (Int32.to_int i)
+    | Nativeint i -> `Int (Nativeint.to_int i)
+    | Int64 i -> `Int (Int64.to_int i)
+    | Bool b -> `Bool b
+    | String s -> `String s
+    | Bytes s -> `String (Bytes.to_string s)
+    | Char c -> `String (String.make 1 c)
+    | Float f -> `Float f
+    | Option None -> `String "<none>"
+    | Option (Some s) -> of_dyn s
+    | List xs -> `List (List.map ~f:of_dyn xs)
+    | Array xs -> `List (List.map ~f:of_dyn (Array.to_list xs))
+    | Tuple xs -> `List (List.map ~f:of_dyn xs)
+    | Record r -> `Assoc (List.map r ~f:(fun (k, v) -> k, of_dyn v))
+    | Variant (name, args) -> `Assoc [ name, of_dyn (List args) ]
+    | Set xs -> `List (List.map ~f:of_dyn xs)
+    | Map map -> `List (List.map map ~f:(fun (k, v) -> `List [ of_dyn k; of_dyn v ]))
+  ;;
+end
+
+module Log = struct
+  let level : (string option -> bool) ref = ref (fun _ -> false)
+  let out = ref Format.err_formatter
+
+  type message =
+    { message : string
+    ; payload : (string * Json.t) list
+    }
+
+  let msg message payload = { message; payload }
+
+  let log ?section k =
+    if !level section
+    then (
+      let message = k () in
+      (match section with
+       | None -> Format.fprintf !out "%s@." message.message
+       | Some section -> Format.fprintf !out "[%s] %s@." section message.message);
+      (match message.payload with
+       | [] -> ()
+       | fields -> Format.fprintf !out "%a@." Json.pp (`Assoc fields));
+      Format.pp_print_flush !out ())
+  ;;
+end
+
+let sprintf = Printf.sprintf
+
+let () =
+  Printexc.register_printer (function
+    | Jsonrpc.Response.Error.E t ->
+      let json = Jsonrpc.Response.Error.yojson_of_t t in
+      Some ("jsonrpc response error " ^ Json.to_pretty_string (json :> Json.t))
+    | _ -> None)
+;;

thirdparty/lsp/jsonrpc-fiber/src/jsonrpc_fiber.ml

@@ -0,0 +1,369 @@
+open Import
+open Fiber.O
+
+module Id = struct
+  include Id
+  module Table = Stdlib.MoreLabels.Hashtbl.Make (Id)
+end
+
+module Notify = struct
+  type t =
+    | Stop
+    | Continue
+end
+
+module Sender = struct
+  type t =
+    { mutable called : bool
+    ; for_ : Id.t
+    ; send : Response.t -> unit Fiber.t
+    }
+
+  let make id send = { for_ = id; called = false; send }
+
+  let send t (r : Response.t) : unit Fiber.t =
+    Fiber.of_thunk (fun () ->
+      if t.called
+      then Code_error.raise "cannot send response twice" []
+      else if not (Id.equal t.for_ r.id)
+      then Code_error.raise "invalid id" []
+      else t.called <- true;
+      t.send r)
+  ;;
+end
+
+exception Stopped of Request.t
+
+let () =
+  Printexc.register_printer (function
+    | Stopped req ->
+      let json = Request.yojson_of_t req in
+      Some ("Session closed. Request will not be answered. " ^ Json.to_pretty_string json)
+    | _ -> None)
+;;
+
+module Reply = struct
+  type t =
+    | Now of Response.t
+    | Later of ((Response.t -> unit Fiber.t) -> unit Fiber.t)
+
+  let now (r : Response.t) = Now r
+  let later f = Later f
+
+  let send (t : t) sender =
+    match t with
+    | Now r -> Sender.send sender r
+    | Later f -> f (fun (r : Response.t) -> Sender.send sender r)
+  ;;
+end
+
+module Make (Chan : sig
+    type t
+
+    val send : t -> Packet.t list -> unit Fiber.t
+    val recv : t -> Packet.t option Fiber.t
+    val close : t -> [ `Read | `Write ] -> unit Fiber.t
+  end) =
+struct
+  type 'state t =
+    { chan : Chan.t
+    ; on_request : ('state, Request.t) context -> (Reply.t * 'state) Fiber.t
+    ; on_notification : ('state, Notification.t) context -> (Notify.t * 'state) Fiber.t
+    ; pending : (Response.t, [ `Stopped | `Cancelled ]) result Fiber.Ivar.t Id.Table.t
+    ; stopped : unit Fiber.Ivar.t
+    ; name : string
+    ; mutable running : bool
+    ; mutable tick : int
+    ; mutable state : 'state
+    ; mutable pending_requests_stopped : bool
+    }
+
+  and ('a, 'message) context = 'a t * 'message
+
+  type cancel = unit Fiber.t
+
+  let fire cancel = cancel
+
+  module Context = struct
+    type nonrec ('a, 'id) t = ('a, 'id) context
+
+    let message = snd
+    let session = fst
+    let state t = (session t).state
+  end
+
+  let log t = Log.log ~section:t.name
+
+  let response_of_exn id (exn : Exn_with_backtrace.t) =
+    let error =
+      match exn.exn with
+      | Jsonrpc.Response.Error.E resp -> resp
+      | _ ->
+        let data = exn |> Exn_with_backtrace.to_dyn |> Json.of_dyn in
+        Response.Error.make ~code:InternalError ~data ~message:"uncaught exception" ()
+    in
+    Response.error id error
+  ;;
+
+  let on_request_fail ctx : (Reply.t * _) Fiber.t =
+    let req : Request.t = Context.message ctx in
+    let state = Context.state ctx in
+    let error = Response.Error.make ~code:InternalError ~message:"not implemented" () in
+    Fiber.return (Reply.now (Response.error req.id error), state)
+  ;;
+
+  let state t = t.state
+
+  let on_notification_fail ctx =
+    let state = Context.state ctx in
+    Fiber.return (Notify.Continue, state)
+  ;;
+
+  let stop_pending_requests t =
+    Fiber.of_thunk (fun () ->
+      if t.pending_requests_stopped
+      then Fiber.return ()
+      else (
+        t.pending_requests_stopped <- true;
+        let to_cancel =
+          Id.Table.fold t.pending ~init:[] ~f:(fun ~key:_ ~data:x acc -> x :: acc)
+        in
+        Id.Table.clear t.pending;
+        Fiber.parallel_iter to_cancel ~f:(fun ivar ->
+          let* res = Fiber.Ivar.peek ivar in
+          match res with
+          | Some _ -> Fiber.return ()
+          | None -> Fiber.Ivar.fill ivar (Error `Stopped))))
+  ;;
+
+  let create
+        ?(on_request = on_request_fail)
+        ?(on_notification = on_notification_fail)
+        ~name
+        chan
+        state
+    =
+    let pending = Id.Table.create 10 in
+    { chan
+    ; on_request
+    ; on_notification
+    ; pending
+    ; stopped = Fiber.Ivar.create ()
+    ; name
+    ; running = false
+    ; tick = 0
+    ; state
+    ; pending_requests_stopped = false
+    }
+  ;;
+
+  let stopped t = Fiber.Ivar.read t.stopped
+
+  let stop t =
+    Fiber.fork_and_join_unit
+      (fun () -> Chan.close t.chan `Read)
+      (fun () -> stop_pending_requests t)
+  ;;
+
+  let close t =
+    Fiber.all_concurrently_unit
+      [ Chan.close t.chan `Read
+      ; Chan.close t.chan `Write
+      ; Fiber.Ivar.fill t.stopped ()
+      ; stop_pending_requests t
+      ]
+  ;;
+
+  let run t =
+    let send_response resp =
+      log t (fun () ->
+        Log.msg "sending response" [ "response", Response.yojson_of_t resp ]);
+      Chan.send t.chan [ Response resp ]
+    in
+    let later = Fiber.Pool.create () in
+    let rec loop () =
+      t.tick <- t.tick + 1;
+      log t (fun () -> Log.msg "new tick" [ "tick", `Int t.tick ]);
+      let* res = Chan.recv t.chan in
+      log t (fun () -> Log.msg "waited for something" []);
+      match res with
+      | None -> Fiber.return ()
+      | Some packet ->
+        (match packet with
+         | Notification r -> on_notification r
+         | Request r -> on_request r
+         | Response r ->
+           let* () = Fiber.Pool.task later ~f:(fun () -> on_response r) in
+           loop ()
+         | Batch_call _ -> Code_error.raise "batch requests aren't supported" []
+         | Batch_response _ -> assert false)
+    and on_response r =
+      let log (what : string) =
+        log t (fun () -> Log.msg ("response " ^ what) [ "r", Response.yojson_of_t r ])
+      in
+      match Id.Table.find_opt t.pending r.id with
+      | None ->
+        log "dropped";
+        Fiber.return ()
+      | Some ivar ->
+        log "acknowledged";
+        Id.Table.remove t.pending r.id;
+        let* resp = Fiber.Ivar.peek ivar in
+        (match resp with
+         | Some _ -> Fiber.return ()
+         | None -> Fiber.Ivar.fill ivar (Ok r))
+    and on_request (r : Request.t) =
+      log t (fun () -> Log.msg "handling request" []);
+      let* result =
+        let sent = ref false in
+        Fiber.map_reduce_errors
+          (module Stdune.Monoid.Unit)
+          ~on_error:(fun exn_bt ->
+            if !sent
+            then (* TODO log *)
+              Fiber.return ()
+            else (
+              let response = response_of_exn r.id exn_bt in
+              sent := true;
+              Fiber.Pool.task later ~f:(fun () -> send_response response)))
+          (fun () -> t.on_request (t, r))
+      in
+      log t (fun () -> Log.msg "received result" []);
+      match result with
+      | Error () -> loop ()
+      | Ok (reply, state) ->
+        t.state <- state;
+        let sender = Sender.make r.id send_response in
+        let* () =
+          Fiber.Pool.task later ~f:(fun () ->
+            let+ res =
+              Fiber.map_reduce_errors
+                (module Stdune.Monoid.Unit)
+                (fun () -> Reply.send reply sender)
+                ~on_error:(fun exn_bt ->
+                  if sender.called
+                  then (* TODO we should log *)
+                    Fiber.return ()
+                  else (
+                    let resp = response_of_exn r.id exn_bt in
+                    Sender.send sender resp))
+            in
+            match res with
+            | Ok () -> ()
+            | Error () -> ())
+        in
+        loop ()
+    and on_notification (r : Notification.t) : unit Fiber.t =
+      let* res = Fiber.collect_errors (fun () -> t.on_notification (t, r)) in
+      match res with
+      | Ok (next, state) ->
+        t.state <- state;
+        (match next with
+         | Stop -> Fiber.return ()
+         | Continue -> loop ())
+      | Error errors ->
+        Format.eprintf
+          "Uncaught error when handling notification:@.%a@.Error:@.%s@."
+          Json.pp
+          (Notification.yojson_of_t r)
+          (Dyn.to_string (Dyn.list Exn_with_backtrace.to_dyn errors));
+        loop ()
+    in
+    Fiber.of_thunk (fun () ->
+      t.running <- true;
+      let* () =
+        Fiber.fork_and_join_unit
+          (fun () ->
+             let* () = loop () in
+             Fiber.Pool.stop later)
+          (fun () -> Fiber.Pool.run later)
+      in
+      close t)
+  ;;
+
+  let check_running t =
+    if not t.running then Code_error.raise "jsonrpc must be running" []
+  ;;
+
+  let notification t (n : Notification.t) =
+    Fiber.of_thunk (fun () ->
+      check_running t;
+      Chan.send t.chan [ Notification n ])
+  ;;
+
+  let register_request_ivar t id ivar =
+    match Id.Table.find_opt t.pending id with
+    | Some _ -> Code_error.raise "duplicate request id" []
+    | None -> Id.Table.add t.pending ~key:id ~data:ivar
+  ;;
+
+  let read_request_ivar req ivar =
+    let+ res = Fiber.Ivar.read ivar in
+    match res with
+    | Ok s -> s
+    | Error `Cancelled -> assert false
+    | Error `Stopped -> raise (Stopped req)
+  ;;
+
+  let request t (req : Request.t) =
+    Fiber.of_thunk (fun () ->
+      check_running t;
+      let* () = Chan.send t.chan [ Request req ] in
+      let ivar = Fiber.Ivar.create () in
+      register_request_ivar t req.id ivar;
+      read_request_ivar req ivar)
+  ;;
+
+  let request_with_cancel t (req : Request.t) =
+    let ivar = Fiber.Ivar.create () in
+    let cancel = Fiber.Ivar.fill ivar (Error `Cancelled) in
+    let resp =
+      Fiber.of_thunk (fun () ->
+        check_running t;
+        let* () =
+          let+ () = Chan.send t.chan [ Request req ] in
+          register_request_ivar t req.id ivar
+        in
+        let+ res = Fiber.Ivar.read ivar in
+        match res with
+        | Ok s -> `Ok s
+        | Error `Cancelled -> `Cancelled
+        | Error `Stopped -> raise (Stopped req))
+    in
+    cancel, resp
+  ;;
+
+  module Batch = struct
+    type response =
+      Jsonrpc.Request.t
+      * (Jsonrpc.Response.t, [ `Stopped | `Cancelled ]) result Fiber.Ivar.t
+
+    type t = [ `Notification of Notification.t | `Request of response ] list ref
+
+    let await (req, resp) = read_request_ivar req resp
+    let create () = ref []
+    let notification t n = t := `Notification n :: !t
+
+    let request (t : t) r : response =
+      let ivar = Fiber.Ivar.create () in
+      let resp = r, ivar in
+      t := `Request resp :: !t;
+      resp
+    ;;
+  end
+
+  let submit (t : _ t) (batch : Batch.t) =
+    Fiber.of_thunk (fun () ->
+      check_running t;
+      let pending = !batch in
+      batch := [];
+      let pending, ivars =
+        List.fold_left pending ~init:([], []) ~f:(fun (pending, ivars) -> function
+          | `Notification n -> Jsonrpc.Packet.Notification n :: pending, ivars
+          | `Request ((r : Request.t), ivar) ->
+            Jsonrpc.Packet.Request r :: pending, (r.id, ivar) :: ivars)
+      in
+      List.iter ivars ~f:(fun (id, ivar) -> register_request_ivar t id ivar);
+      Chan.send t.chan pending)
+  ;;
+end

thirdparty/lsp/jsonrpc-fiber/src/jsonrpc_fiber.mli

@@ -0,0 +1,75 @@
+module Notify : sig
+  type t =
+    | Stop
+    | Continue
+end
+
+module Reply : sig
+  type t
+
+  val now : Jsonrpc.Response.t -> t
+  val later : ((Jsonrpc.Response.t -> unit Fiber.t) -> unit Fiber.t) -> t
+end
+
+(** Raised when the server is shutdown and a pending request will not complete. *)
+exception Stopped of Jsonrpc.Request.t
+
+(** IO free implementation of the jsonrpc protocol. We stay completely agnostic
+    of transport by only dealing with abstract jsonrpc packets *)
+module Make (Chan : sig
+    type t
+
+    val send : t -> Jsonrpc.Packet.t list -> unit Fiber.t
+    val recv : t -> Jsonrpc.Packet.t option Fiber.t
+    val close : t -> [ `Read | `Write ] -> unit Fiber.t
+  end) : sig
+  type 'state t
+
+  module Context : sig
+    type 'a session := 'a t
+    type ('state, 'message) t
+
+    val message : (_, 'message) t -> 'message
+    val state : ('a, _) t -> 'a
+    val session : ('a, _) t -> 'a session
+  end
+
+  val create
+    :  ?on_request:(('state, Jsonrpc.Request.t) Context.t -> (Reply.t * 'state) Fiber.t)
+    -> ?on_notification:
+         (('state, Jsonrpc.Notification.t) Context.t -> (Notify.t * 'state) Fiber.t)
+    -> name:string
+    -> Chan.t
+    -> 'state
+    -> 'state t
+
+  val state : 'a t -> 'a
+  val stop : _ t -> unit Fiber.t
+  val stopped : _ t -> unit Fiber.t
+  val run : _ t -> unit Fiber.t
+  val notification : _ t -> Jsonrpc.Notification.t -> unit Fiber.t
+  val request : _ t -> Jsonrpc.Request.t -> Jsonrpc.Response.t Fiber.t
+
+  type cancel
+
+  val fire : cancel -> unit Fiber.t
+
+  val request_with_cancel
+    :  _ t
+    -> Jsonrpc.Request.t
+    -> cancel * [ `Ok of Jsonrpc.Response.t | `Cancelled ] Fiber.t
+
+  module Batch : sig
+    type t
+
+    val create : unit -> t
+    val notification : t -> Jsonrpc.Notification.t -> unit
+
+    type response
+
+    val await : response -> Jsonrpc.Response.t Fiber.t
+    val request : t -> Jsonrpc.Request.t -> response
+  end
+
+  val submit : _ t -> Batch.t -> unit Fiber.t
+end

thirdparty/lsp/jsonrpc-fiber/test/dune

@@ -0,0 +1,22 @@
+(library
+ (name jsonrpc_fiber_tests)
+ (enabled_if
+  (>= %{ocaml_version} 4.08))
+ (inline_tests)
+ (libraries
+  base
+  dyn
+  fiber
+  fiber_test
+  jsonrpc
+  jsonrpc_fiber
+  ;; This is because of the (implicit_transitive_deps false)
+  ;; in dune-project
+  ppx_expect
+  ppx_expect.config
+  ppx_expect.config_types
+  ppx_inline_test.config
+  stdune
+  yojson)
+ (preprocess
+  (pps ppx_expect)))

thirdparty/lsp/jsonrpc-fiber/test/jsonrpc_fiber_tests.ml

@@ -0,0 +1,342 @@
+open Stdune
+open Jsonrpc
+open Jsonrpc_fiber
+open Fiber.O
+open Fiber.Stream
+
+module Stream_chan = struct
+  type t = Jsonrpc.Packet.t In.t * Jsonrpc.Packet.t Out.t
+
+  let close (_, o) what =
+    match what with
+    | `Read -> Fiber.return ()
+    | `Write -> Out.write o None
+  ;;
+
+  let send (_, o) p = Fiber.sequential_iter p ~f:(fun x -> Out.write o (Some x))
+  let recv (i, _) = In.read i
+end
+
+module Jrpc = Jsonrpc_fiber.Make (Stream_chan)
+module Context = Jrpc.Context
+
+let print_json json = print_endline (Yojson.Safe.pretty_to_string ~std:false json)
+
+let no_output () =
+  let received_none = ref false in
+  Out.create (function
+    | None ->
+      if !received_none
+      then failwith "received None more than once"
+      else received_none := true;
+      Fiber.return ()
+    | Some _ -> failwith "unexpected element")
+;;
+
+let%expect_test "start and stop server" =
+  let run () =
+    let in_ = In.of_list [] in
+    let jrpc = Jrpc.create ~name:"test" (in_, no_output ()) () in
+    let run = Jrpc.run jrpc in
+    Fiber.fork_and_join_unit (fun () -> run) (fun () -> Jrpc.stop jrpc)
+  in
+  let () = Fiber_test.test Dyn.opaque run in
+  [%expect
+    {|
+    <opaque> |}]
+;;
+
+let%expect_test "server accepts notifications" =
+  let notif =
+    { Jsonrpc.Notification.method_ = "method"; params = Some (`List [ `String "bar" ]) }
+  in
+  let run () =
+    let in_ = In.of_list [ Jsonrpc.Packet.Notification notif ] in
+    let on_notification c =
+      let n = Context.message c in
+      let state = Context.state c in
+      assert (notif = n);
+      print_endline "received notification";
+      Fiber.return (Notify.Stop, state)
+    in
+    let jrpc = Jrpc.create ~name:"test" ~on_notification (in_, no_output ()) () in
+    Jrpc.run jrpc
+  in
+  Fiber_test.test Dyn.opaque run;
+  [%expect
+    {|
+    received notification
+    <opaque> |}]
+;;
+
+let of_ref ref =
+  Fiber.Stream.Out.create (function
+    | None -> Fiber.return ()
+    | Some x ->
+      ref := x :: !ref;
+      Fiber.return ())
+;;
+
+let%expect_test "serving requests" =
+  let id = `Int 1 in
+  let request =
+    { Jsonrpc.Request.id; method_ = "bla"; params = Some (`List [ `Int 100 ]) }
+  in
+  let response_data = `String "response" in
+  let run () =
+    let responses = ref [] in
+    let in_ = In.of_list [ Jsonrpc.Packet.Request request ] in
+    let on_request c =
+      let r = Context.message c in
+      let state = Context.state c in
+      assert (r = request);
+      let response = Jsonrpc.Response.ok r.id response_data in
+      Fiber.return (Reply.now response, state)
+    in
+    let out = of_ref responses in
+    let jrpc = Jrpc.create ~name:"test" ~on_request (in_, out) () in
+    let+ () = Jrpc.run jrpc in
+    List.iter !responses ~f:(fun resp ->
+      let json = Jsonrpc.Packet.yojson_of_t resp in
+      print_endline (Yojson.Safe.pretty_to_string ~std:false json))
+  in
+  Fiber_test.test Dyn.opaque run;
+  [%expect
+    {|
+    { "id": 1, "jsonrpc": "2.0", "result": "response" }
+    <opaque> |}]
+;;
+
+(* The current client/server implement has no concurrent handling of requests.
+   We can show this when we try to send a request when handling a response. *)
+let%expect_test "concurrent requests" =
+  let print packet =
+    print_endline
+      (Yojson.Safe.pretty_to_string ~std:false (Jsonrpc.Packet.yojson_of_t packet))
+  in
+  let waiter chan =
+    let on_request c =
+      let self = Context.session c in
+      let request = Context.message c in
+      print_endline "waiter: received request";
+      print (Request request);
+      let response =
+        Reply.later (fun send ->
+          print_endline "waiter: sending response";
+          let* () = send (Jsonrpc.Response.ok request.id `Null) in
+          print_endline "waiter: making request";
+          let* response =
+            let request = Jsonrpc.Request.create ~id:(`Int 100) ~method_:"shutdown" () in
+            Jrpc.request self request
+          in
+          print_endline "waiter: received response:";
+          print (Response response);
+          let* () = send (Jsonrpc.Response.ok request.id `Null) in
+          print_endline "waiter: stopping";
+          let+ () = Jrpc.stop self in
+          print_endline "waiter: stopped")
+      in
+      Fiber.return (response, ())
+    in
+    Jrpc.create ~name:"waiter" ~on_request chan ()
+  in
+  let waitee chan =
+    let on_request c =
+      print_endline "waitee: received request";
+      let request = Context.message c in
+      print (Request request);
+      let response =
+        Reply.later (fun send ->
+          let* () = send (Jsonrpc.Response.ok request.id (`Int 42)) in
+          if request.method_ = "shutdown"
+          then (
+            let self = Context.session c in
+            print_endline "waitee: stopping";
+            let+ () = Jrpc.stop self in
+            print_endline "waitee: stopped")
+          else Fiber.return ())
+      in
+      let state = Context.state c in
+      Fiber.return (response, state)
+    in
+    Jrpc.create ~on_request ~name:"waitee" chan ()
+  in
+  let waitee_in, waiter_out = pipe () in
+  let waiter_in, waitee_out = pipe () in
+  let waitee = waitee (waitee_in, waitee_out) in
+  let waiter = waiter (waiter_in, waiter_out) in
+  let run () =
+    let initial_request () =
+      let request = Jsonrpc.Request.create ~id:(`String "initial") ~method_:"init" () in
+      print_endline "initial: waitee requests from waiter";
+      let+ resp = Jrpc.request waitee request in
+      print_endline "initial request response:";
+      print (Response resp)
+    in
+    Fiber.all_concurrently_unit [ Jrpc.run waitee; initial_request (); Jrpc.run waiter ]
+  in
+  Fiber_test.test Dyn.opaque run;
+  [%expect
+    {|
+    initial: waitee requests from waiter
+    waiter: received request
+    { "id": "initial", "method": "init", "jsonrpc": "2.0" }
+    waiter: sending response
+    waiter: making request
+    waitee: received request
+    { "id": 100, "method": "shutdown", "jsonrpc": "2.0" }
+    waitee: stopping
+    waitee: stopped
+    initial request response:
+    { "id": "initial", "jsonrpc": "2.0", "result": null }
+    waiter: received response:
+    { "id": 100, "jsonrpc": "2.0", "result": 42 }
+    [FAIL] unexpected Never raised |}]
+;;
+
+let%expect_test "test from jsonrpc_test.ml" =
+  Printexc.record_backtrace false;
+  let response =
+    let i = ref 0 in
+    fun () ->
+      incr i;
+      `Int !i
+  in
+  let on_request ctx =
+    let req : Jsonrpc.Request.t = Context.message ctx in
+    let state = Context.state ctx in
+    Fiber.return (Reply.now (Jsonrpc.Response.ok req.id (response ())), state)
+  in
+  let on_notification ctx =
+    let n : Jsonrpc.Notification.t = Context.message ctx in
+    if n.method_ = "raise" then failwith "special failure";
+    let json = Notification.yojson_of_t n in
+    print_endline ">> received notification";
+    print_json json;
+    Fiber.return (Jsonrpc_fiber.Notify.Continue, ())
+  in
+  let responses = ref [] in
+  let initial_requests =
+    let request ?params id method_ : Jsonrpc.Packet.t =
+      Request (Jsonrpc.Request.create ?params ~id ~method_ ())
+    in
+    let notification ?params method_ : Jsonrpc.Packet.t =
+      Notification (Jsonrpc.Notification.create ?params ~method_ ())
+    in
+    [ request (`Int 10) "foo"
+    ; request (`String "testing") "bar"
+    ; notification "notif1"
+    ; notification "notif2"
+    ; notification "raise"
+    ]
+  in
+  let reqs_in, reqs_out = pipe () in
+  let chan =
+    let out = of_ref responses in
+    reqs_in, out
+  in
+  let session = Jrpc.create ~on_notification ~on_request ~name:"test" chan () in
+  let write_reqs () =
+    let* () =
+      Fiber.sequential_iter initial_requests ~f:(fun req -> Out.write reqs_out (Some req))
+    in
+    Out.write reqs_out None
+  in
+  Fiber_test.test Dyn.opaque (fun () ->
+    Fiber.fork_and_join_unit write_reqs (fun () -> Jrpc.run session));
+  List.rev !responses
+  |> List.iter ~f:(fun packet ->
+    let json = Jsonrpc.Packet.yojson_of_t packet in
+    print_json json);
+  [%expect
+    {|
+    >> received notification
+    { "method": "notif1", "jsonrpc": "2.0" }
+    >> received notification
+    { "method": "notif2", "jsonrpc": "2.0" }
+    Uncaught error when handling notification:
+    { "method": "raise", "jsonrpc": "2.0" }
+    Error:
+    [ { exn = "Failure(\"special failure\")"; backtrace = "" } ]
+    <opaque>
+    { "id": 10, "jsonrpc": "2.0", "result": 1 }
+    { "id": "testing", "jsonrpc": "2.0", "result": 2 } |}]
+;;
+
+let%expect_test "cancellation" =
+  let () = Printexc.record_backtrace true in
+  let print packet =
+    print_endline
+      (Yojson.Safe.pretty_to_string ~std:false (Jsonrpc.Packet.yojson_of_t packet))
+  in
+  let server_req_ack = Fiber.Ivar.create () in
+  let client_req_ack = Fiber.Ivar.create () in
+  let server chan =
+    let on_request c =
+      let request = Context.message c in
+      let state = Context.state c in
+      print_endline "server: received request";
+      print (Request request);
+      let* () = Fiber.Ivar.fill server_req_ack () in
+      let response =
+        Reply.later (fun send ->
+          print_endline "server: waiting for client ack before sending response";
+          let* () = Fiber.Ivar.read client_req_ack in
+          print_endline "server: got client ack, sending response";
+          send (Jsonrpc.Response.ok request.id (`String "Ok")))
+      in
+      Fiber.return (response, state)
+    in
+    Jrpc.create ~name:"server" ~on_request chan ()
+  in
+  let client chan = Jrpc.create ~name:"client" chan () in
+  let run () =
+    let client_in, client_out = pipe () in
+    let server_in, server_out = pipe () in
+    let client = client (client_in, server_out) in
+    let server = server (server_in, client_out) in
+    let request = Jsonrpc.Request.create ~id:(`String "initial") ~method_:"init" () in
+    let cancel, req = Jrpc.request_with_cancel client request in
+    let fire_cancellation =
+      let* () = Fiber.return () in
+      print_endline "client: waiting for server ack before cancelling request";
+      let* () = Fiber.Ivar.read server_req_ack in
+      print_endline "client: got server ack, cancelling request";
+      let* () = Jrpc.fire cancel in
+      Fiber.Ivar.fill client_req_ack ()
+    in
+    let initial_request =
+      let* () = Fiber.return () in
+      print_endline "client: sending request";
+      let+ resp = req in
+      match resp with
+      | `Cancelled -> print_endline "request has been cancelled"
+      | `Ok resp ->
+        print_endline "request response:";
+        print (Response resp)
+    in
+    Fiber.all_concurrently
+      [ fire_cancellation
+      ; Jrpc.run client
+      ; initial_request
+        >>> Fiber.fork_and_join_unit
+              (fun () -> Out.write server_out None >>> Jrpc.stop client)
+              (fun () -> Jrpc.stop server)
+      ; Jrpc.run server
+      ; Jrpc.stopped client
+      ; Jrpc.stopped server
+      ]
+  in
+  Fiber_test.test Dyn.opaque run;
+  [%expect
+    {|
+    client: waiting for server ack before cancelling request
+    client: sending request
+    server: received request
+    { "id": "initial", "method": "init", "jsonrpc": "2.0" }
+    server: waiting for client ack before sending response
+    client: got server ack, cancelling request
+    request has been cancelled
+    server: got client ack, sending response
+    <opaque> |}]
+;;

thirdparty/lsp/jsonrpc.opam

@@ -0,0 +1,41 @@
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+synopsis: "Jsonrpc protocol implemenation"
+description: "See https://www.jsonrpc.org/specification"
+maintainer: ["Rudi Grinberg <me@rgrinberg.com>"]
+authors: [
+  "Andrey Popp <8mayday@gmail.com>"
+  "Rusty Key <iam@stfoo.ru>"
+  "Louis Roché <louis@louisroche.net>"
+  "Oleksiy Golovko <alexei.golovko@gmail.com>"
+  "Rudi Grinberg <me@rgrinberg.com>"
+  "Sacha Ayoun <sachaayoun@gmail.com>"
+  "cannorin <cannorin@gmail.com>"
+  "Ulugbek Abdullaev <ulugbekna@gmail.com>"
+  "Thibaut Mattio <thibaut.mattio@gmail.com>"
+  "Max Lantas <mnxndev@outlook.com>"
+]
+license: "ISC"
+homepage: "https://github.com/ocaml/ocaml-lsp"
+bug-reports: "https://github.com/ocaml/ocaml-lsp/issues"
+depends: [
+  "dune" {>= "3.0"}
+  "ocaml" {>= "4.08"}
+  "odoc" {with-doc}
+]
+dev-repo: "git+https://github.com/ocaml/ocaml-lsp.git"
+build: [
+  ["dune" "subst"] {dev}
+  [
+    "dune"
+    "build"
+    "-p"
+    name
+    "-j"
+    jobs
+    "@install"
+    "@doc" {with-doc}
+  ]
+]
+
+x-maintenance-intent: [ "(latest)" "(latest)-414" ]

thirdparty/lsp/jsonrpc/src/dune

@@ -0,0 +1,4 @@
+(library
+ (public_name jsonrpc)
+ (instrumentation
+  (backend bisect_ppx)))

thirdparty/lsp/jsonrpc/src/import.ml

@@ -0,0 +1,60 @@
+module List = ListLabels
+
+module Option = struct
+  let map t ~f =
+    match t with
+    | None -> None
+    | Some x -> Some (f x)
+  ;;
+end
+
+module Json = struct
+  type t =
+    [ `Assoc of (string * t) list
+    | `Bool of bool
+    | `Float of float
+    | `Int of int
+    | `Intlit of string
+    | `List of t list
+    | `Null
+    | `String of string
+    | `Tuple of t list
+    | `Variant of string * t option
+    ]
+
+  exception Of_json of (string * t)
+
+  let () =
+    Printexc.register_printer (function
+      | Of_json (msg, _) -> Some ("Jsonrpc: json conversion failed: " ^ msg)
+      | _ -> None)
+  ;;
+
+  let error msg json = raise (Of_json (msg, json))
+
+  module Jsonable = struct
+    module type S = sig
+        type json
+        type t
+
+        val yojson_of_t : t -> json
+        val t_of_yojson : json -> t
+      end
+      with type json := t
+  end
+
+  let field fields name conv = List.assoc_opt name fields |> Option.map ~f:conv
+
+  let field_exn fields name conv =
+    match field fields name conv with
+    | Some f -> f
+    | None -> error ("missing field " ^ name) (`Assoc fields)
+  ;;
+
+  module Conv = struct
+    let string_of_yojson = function
+      | `String s -> s
+      | json -> error "expected string" json
+    ;;
+  end
+end

thirdparty/lsp/jsonrpc/src/jsonrpc.ml

@@ -0,0 +1,319 @@
+open Import
+open Json.Conv
+module Json = Json
+
+module Id = struct
+  type t =
+    [ `String of string
+    | `Int of int
+    ]
+
+  let yojson_of_t = function
+    | `String s -> `String s
+    | `Int i -> `Int i
+  ;;
+
+  let t_of_yojson = function
+    | `String s -> `String s
+    | `Int i -> `Int i
+    | json -> Json.error "Id.t" json
+  ;;
+
+  let hash x = Hashtbl.hash x
+  let equal = ( = )
+end
+
+module Constant = struct
+  let jsonrpc = "jsonrpc"
+  let jsonrpcv = "2.0"
+  let id = "id"
+  let method_ = "method"
+  let params = "params"
+  let result = "result"
+  let error = "error"
+end
+
+let assert_jsonrpc_version fields =
+  let jsonrpc = Json.field_exn fields Constant.jsonrpc Json.Conv.string_of_yojson in
+  if not (String.equal jsonrpc Constant.jsonrpcv)
+  then
+    Json.error
+      ("invalid packet: jsonrpc version doesn't match " ^ jsonrpc)
+      (`Assoc fields)
+;;
+
+module Structured = struct
+  type t =
+    [ `Assoc of (string * Json.t) list
+    | `List of Json.t list
+    ]
+
+  let t_of_yojson = function
+    | `Assoc xs -> `Assoc xs
+    | `List xs -> `List xs
+    | json -> Json.error "invalid structured value" json
+  ;;
+
+  let yojson_of_t t = (t :> Json.t)
+end
+
+module Notification = struct
+  type t =
+    { method_ : string
+    ; params : Structured.t option
+    }
+
+  let fields ~method_ ~params =
+    let json =
+      [ Constant.method_, `String method_; Constant.jsonrpc, `String Constant.jsonrpcv ]
+    in
+    match params with
+    | None -> json
+    | Some params -> (Constant.params, (params :> Json.t)) :: json
+  ;;
+
+  let yojson_of_t { method_; params } = `Assoc (fields ~method_ ~params)
+  let create ?params ~method_ () = { params; method_ }
+end
+
+module Request = struct
+  type t =
+    { id : Id.t
+    ; method_ : string
+    ; params : Structured.t option
+    }
+
+  let yojson_of_t { id; method_; params } =
+    let fields = Notification.fields ~method_ ~params in
+    `Assoc ((Constant.id, Id.yojson_of_t id) :: fields)
+  ;;
+
+  let create ?params ~id ~method_ () = { params; id; method_ }
+end
+
+module Response = struct
+  module Error = struct
+    module Code = struct
+      type t =
+        | ParseError
+        | InvalidRequest
+        | MethodNotFound
+        | InvalidParams
+        | InternalError
+        (* the codes below are LSP specific *)
+        | ServerErrorStart
+        | ServerErrorEnd
+        | ServerNotInitialized
+        | UnknownErrorCode
+        | RequestFailed
+        | ServerCancelled
+        | ContentModified
+        | RequestCancelled
+        (* all other codes are custom *)
+        | Other of int
+
+      let of_int = function
+        | -32700 -> ParseError
+        | -32600 -> InvalidRequest
+        | -32601 -> MethodNotFound
+        | -32602 -> InvalidParams
+        | -32603 -> InternalError
+        | -32099 -> ServerErrorStart
+        | -32000 -> ServerErrorEnd
+        | -32002 -> ServerNotInitialized
+        | -32001 -> UnknownErrorCode
+        | -32800 -> RequestCancelled
+        | -32801 -> ContentModified
+        | -32802 -> ServerCancelled
+        | -32803 -> RequestFailed
+        | code -> Other code
+      ;;
+
+      let to_int = function
+        | ParseError -> -32700
+        | InvalidRequest -> -32600
+        | MethodNotFound -> -32601
+        | InvalidParams -> -32602
+        | InternalError -> -32603
+        | ServerErrorStart -> -32099
+        | ServerErrorEnd -> -32000
+        | ServerNotInitialized -> -32002
+        | UnknownErrorCode -> -32001
+        | RequestCancelled -> -32800
+        | ContentModified -> -32801
+        | ServerCancelled -> -32802
+        | RequestFailed -> -32803
+        | Other code -> code
+      ;;
+
+      let t_of_yojson json =
+        match json with
+        | `Int i -> of_int i
+        | _ -> Json.error "invalid code" json
+      ;;
+
+      let yojson_of_t t = `Int (to_int t)
+    end
+
+    type t =
+      { code : Code.t
+      ; message : string
+      ; data : Json.t option
+      }
+
+    let yojson_of_t { code; message; data } =
+      let assoc = [ "code", Code.yojson_of_t code; "message", `String message ] in
+      let assoc =
+        match data with
+        | None -> assoc
+        | Some data -> ("data", data) :: assoc
+      in
+      `Assoc assoc
+    ;;
+
+    let t_of_yojson json =
+      match json with
+      | `Assoc fields ->
+        let code = Json.field_exn fields "code" Code.t_of_yojson in
+        let message = Json.field_exn fields "message" string_of_yojson in
+        let data = Json.field fields "data" (fun x -> x) in
+        { code; message; data }
+      | _ -> Json.error "Jsonrpc.Response.t" json
+    ;;
+
+    exception E of t
+
+    let raise t = raise (E t)
+    let make ?data ~code ~message () = { data; code; message }
+
+    let of_exn exn =
+      let message = Printexc.to_string exn in
+      make ~code:InternalError ~message ()
+    ;;
+  end
+
+  type t =
+    { id : Id.t
+    ; result : (Json.t, Error.t) Result.t
+    }
+
+  let yojson_of_t { id; result } =
+    let result =
+      match result with
+      | Ok json -> Constant.result, json
+      | Error e -> Constant.error, Error.yojson_of_t e
+    in
+    `Assoc
+      [ Constant.id, Id.yojson_of_t id
+      ; Constant.jsonrpc, `String Constant.jsonrpcv
+      ; result
+      ]
+  ;;
+
+  let t_of_yojson json =
+    match json with
+    | `Assoc fields ->
+      let id = Json.field_exn fields Constant.id Id.t_of_yojson in
+      let jsonrpc = Json.field_exn fields Constant.jsonrpc Json.Conv.string_of_yojson in
+      if jsonrpc <> Constant.jsonrpcv
+      then Json.error "Invalid response" json
+      else (
+        match Json.field fields Constant.result (fun x -> x) with
+        | Some res -> { id; result = Ok res }
+        | None ->
+          let result = Error (Json.field_exn fields Constant.error Error.t_of_yojson) in
+          { id; result })
+    | _ -> Json.error "Jsonrpc.Result.t" json
+  ;;
+
+  let make ~id ~result = { id; result }
+  let ok id result = make ~id ~result:(Ok result)
+  let error id error = make ~id ~result:(Error error)
+end
+
+module Packet = struct
+  type t =
+    | Notification of Notification.t
+    | Request of Request.t
+    | Response of Response.t
+    | Batch_response of Response.t list
+    | Batch_call of [ `Request of Request.t | `Notification of Notification.t ] list
+
+  let yojson_of_t = function
+    | Notification r -> Notification.yojson_of_t r
+    | Request r -> Request.yojson_of_t r
+    | Response r -> Response.yojson_of_t r
+    | Batch_response r -> `List (List.map r ~f:Response.yojson_of_t)
+    | Batch_call r ->
+      `List
+        (List.map r ~f:(function
+           | `Request r -> Request.yojson_of_t r
+           | `Notification r -> Notification.yojson_of_t r))
+  ;;
+
+  let t_of_fields (fields : (string * Json.t) list) =
+    assert_jsonrpc_version fields;
+    match Json.field fields Constant.id Id.t_of_yojson with
+    | None ->
+      let method_ = Json.field_exn fields Constant.method_ Json.Conv.string_of_yojson in
+      let params = Json.field fields Constant.params Structured.t_of_yojson in
+      Notification { Notification.params; method_ }
+    | Some id ->
+      (match Json.field fields Constant.method_ Json.Conv.string_of_yojson with
+       | Some method_ ->
+         let params = Json.field fields Constant.params Structured.t_of_yojson in
+         Request { Request.method_; params; id }
+       | None ->
+         Response
+           (match Json.field fields Constant.result (fun x -> x) with
+            | Some result -> { Response.id; result = Ok result }
+            | None ->
+              let error =
+                Json.field_exn fields Constant.error Response.Error.t_of_yojson
+              in
+              { id; result = Error error }))
+  ;;
+
+  let t_of_yojson_single json =
+    match json with
+    | `Assoc fields -> t_of_fields fields
+    | _ -> Json.error "invalid packet" json
+  ;;
+
+  let t_of_yojson (json : Json.t) =
+    match json with
+    | `List [] -> Json.error "invalid packet" json
+    | `List (x :: xs) ->
+      (* we inspect the first element to see what we're dealing with *)
+      let x =
+        match x with
+        | `Assoc fields -> t_of_fields fields
+        | _ -> Json.error "invalid packet" json
+      in
+      (match
+         match x with
+         | Notification x -> `Call (`Notification x)
+         | Request x -> `Call (`Request x)
+         | Response r -> `Response r
+         | _ -> Json.error "invalid packet" json
+       with
+       | `Call x ->
+         Batch_call
+           (x
+            :: List.map xs ~f:(fun call ->
+              let x = t_of_yojson_single call in
+              match x with
+              | Notification n -> `Notification n
+              | Request n -> `Request n
+              | _ -> Json.error "invalid packet" json))
+       | `Response x ->
+         Batch_response
+           (x
+            :: List.map xs ~f:(fun resp ->
+              let resp = t_of_yojson_single resp in
+              match resp with
+              | Response n -> n
+              | _ -> Json.error "invalid packet" json)))
+    | _ -> t_of_yojson_single json
+  ;;
+end

thirdparty/lsp/jsonrpc/src/jsonrpc.mli

@@ -0,0 +1,128 @@
+(** Jsonrpc implementation *)
+
+module Json : sig
+  type t =
+    [ `Assoc of (string * t) list
+    | `Bool of bool
+    | `Float of float
+    | `Int of int
+    | `Intlit of string
+    | `List of t list
+    | `Null
+    | `String of string
+    | `Tuple of t list
+    | `Variant of string * t option
+    ]
+
+  (** Raised when conversions from json fail *)
+  exception Of_json of (string * t)
+
+  module Jsonable : sig
+    module type S = sig
+        type json
+        type t
+
+        val yojson_of_t : t -> json
+        val t_of_yojson : json -> t
+      end
+      with type json := t
+  end
+end
+
+module Id : sig
+  type t =
+    [ `String of string
+    | `Int of int
+    ]
+
+  include Json.Jsonable.S with type t := t
+
+  val hash : t -> int
+  val equal : t -> t -> bool
+end
+
+module Structured : sig
+  type t =
+    [ `Assoc of (string * Json.t) list
+    | `List of Json.t list
+    ]
+
+  include Json.Jsonable.S with type t := t
+end
+
+module Notification : sig
+  type t =
+    { method_ : string
+    ; params : Structured.t option
+    }
+
+  val create : ?params:Structured.t -> method_:string -> unit -> t
+  val yojson_of_t : t -> Json.t
+end
+
+module Request : sig
+  type t =
+    { id : Id.t
+    ; method_ : string
+    ; params : Structured.t option
+    }
+
+  val create : ?params:Structured.t -> id:Id.t -> method_:string -> unit -> t
+  val yojson_of_t : t -> Json.t
+end
+
+module Response : sig
+  module Error : sig
+    module Code : sig
+      type t =
+        | ParseError
+        | InvalidRequest
+        | MethodNotFound
+        | InvalidParams
+        | InternalError
+        | ServerErrorStart
+        | ServerErrorEnd
+        | ServerNotInitialized
+        | UnknownErrorCode
+        | RequestFailed
+        | ServerCancelled
+        | ContentModified
+        | RequestCancelled
+        | Other of int
+    end
+
+    type t =
+      { code : Code.t
+      ; message : string
+      ; data : Json.t option
+      }
+
+    exception E of t
+
+    val make : ?data:Json.t -> code:Code.t -> message:string -> unit -> t
+    val raise : t -> 'a
+    val of_exn : exn -> t
+    val yojson_of_t : t -> Json.t
+  end
+
+  type t =
+    { id : Id.t
+    ; result : (Json.t, Error.t) Result.t
+    }
+
+  val ok : Id.t -> Json.t -> t
+  val error : Id.t -> Error.t -> t
+
+  include Json.Jsonable.S with type t := t
+end
+
+module Packet : sig
+  type t =
+    | Notification of Notification.t
+    | Request of Request.t
+    | Response of Response.t
+    | Batch_response of Response.t list
+    | Batch_call of [ `Request of Request.t | `Notification of Notification.t ] list
+
+  include Json.Jsonable.S with type t := t
+end

thirdparty/lsp/lsp-fiber/src/client.ml

@@ -0,0 +1 @@
+include Rpc.Client

thirdparty/lsp/lsp-fiber/src/client.mli

@@ -0,0 +1 @@
+include module type of Rpc.Client

thirdparty/lsp/lsp-fiber/src/dune

@@ -0,0 +1,14 @@
+(library
+ (name lsp_fiber)
+ (libraries
+  dyn
+  fiber
+  lev_fiber
+  jsonrpc
+  jsonrpc_fiber
+  lsp
+  ppx_yojson_conv_lib
+  stdune
+  yojson)
+ (instrumentation
+  (backend bisect_ppx)))

thirdparty/lsp/lsp-fiber/src/fiber_io.ml

@@ -0,0 +1,55 @@
+open Import
+open Fiber.O
+module Lio = Lev_fiber.Io
+
+type t = Lio.input Lio.t * Lio.output Lio.t * Fiber.Mutex.t
+
+module Io =
+  Io.Make
+    (struct
+      include Fiber
+
+      let raise exn = raise exn
+    end)
+    (struct
+      type input = Lio.Reader.t
+      type output = Lio.Writer.t
+
+      let read_line ic =
+        let+ res = Lio.Reader.read_line ic in
+        match res with
+        | Ok s -> Some s
+        | Error (`Partial_eof _) -> None
+      ;;
+
+      let read_exactly ic len =
+        let+ res = Lio.Reader.read_exactly ic len in
+        match res with
+        | Ok s -> Some s
+        | Error (`Partial_eof _) -> None
+      ;;
+
+      let write oc strings =
+        Fiber.of_thunk (fun () ->
+          List.iter strings ~f:(Lio.Writer.add_string oc);
+          Fiber.return ())
+      ;;
+    end)
+
+let send (_, oc, m) packets =
+  Fiber.Mutex.with_lock m ~f:(fun () ->
+    Lio.with_write oc ~f:(fun writer ->
+      let* () = Fiber.sequential_iter packets ~f:(Io.write writer) in
+      Lio.Writer.flush writer))
+;;
+
+let recv (ic, _, _) = Lio.with_read ic ~f:Io.read
+let make ic oc = ic, oc, Fiber.Mutex.create ()
+
+let close (ic, oc, _) what =
+  Fiber.of_thunk (fun () ->
+    (match what with
+     | `Write -> Lio.close oc
+     | `Read -> Lio.close ic);
+    Fiber.return ())
+;;

thirdparty/lsp/lsp-fiber/src/fiber_io.mli

@@ -0,0 +1,11 @@
+(** Reprsents a bi-directional jsonrpc packet stream read in dedicated threads.
+
+    TODO Nothing here is specific to jsonrpc *)
+open! Import
+
+type t
+
+val close : t -> [ `Read | `Write ] -> unit Fiber.t
+val send : t -> Jsonrpc.Packet.t list -> unit Fiber.t
+val recv : t -> Jsonrpc.Packet.t option Fiber.t
+val make : Lev_fiber.Io.input Lev_fiber.Io.t -> Lev_fiber.Io.output Lev_fiber.Io.t -> t

thirdparty/lsp/lsp-fiber/src/import.ml

@@ -0,0 +1,115 @@
+module List = Stdlib.ListLabels
+module Code_error = Stdune.Code_error
+module Header = Lsp.Header
+module Io = Lsp.Io
+
+module Fdecl : sig
+  type 'a t
+
+  val get : 'a t -> 'a
+  val set : 'a t -> 'a -> unit
+  val create : unit -> 'a t
+end = struct
+  type 'a t = 'a option ref
+
+  let create () = ref None
+
+  let set t x =
+    match !t with
+    | Some _ -> invalid_arg "Fdecl.create: already set"
+    | None -> t := Some x
+  ;;
+
+  let get t =
+    match !t with
+    | None -> invalid_arg "Fdecl.get: not set"
+    | Some t -> t
+  ;;
+end
+
+module Json = struct
+  include Lsp.Import.Json
+
+  let pp ppf (t : t) = Yojson.Safe.pretty_print ppf t
+
+  let rec of_dyn (t : Dyn.t) : t =
+    match t with
+    | Opaque -> `String "<opaque>"
+    | Unit -> `String "()"
+    | Int i -> `Int i
+    | Int32 i -> `Int (Int32.to_int i)
+    | Nativeint i -> `Int (Nativeint.to_int i)
+    | Int64 i -> `Int (Int64.to_int i)
+    | Bool b -> `Bool b
+    | String s -> `String s
+    | Bytes s -> `String (Bytes.to_string s)
+    | Char c -> `String (String.make 1 c)
+    | Float f -> `Float f
+    | Option None -> `String "<none>"
+    | Option (Some s) -> of_dyn s
+    | List xs -> `List (List.map ~f:of_dyn xs)
+    | Array xs -> `List (List.map ~f:of_dyn (Array.to_list xs))
+    | Tuple xs -> `List (List.map ~f:of_dyn xs)
+    | Record r -> `Assoc (List.map r ~f:(fun (k, v) -> k, of_dyn v))
+    | Variant (name, args) -> `Assoc [ name, of_dyn (List args) ]
+    | Set xs -> `List (List.map ~f:of_dyn xs)
+    | Map map -> `List (List.map map ~f:(fun (k, v) -> `List [ of_dyn k; of_dyn v ]))
+  ;;
+
+  let rec to_dyn (t : t) : Dyn.t =
+    match t with
+    | `String s -> String s
+    | `Int i -> Int i
+    | `Float f -> Float f
+    | `Bool f -> Bool f
+    | `Assoc o -> Record (List.map o ~f:(fun (k, v) -> k, to_dyn v))
+    | `List l -> List (List.map l ~f:to_dyn)
+    | `Tuple args -> Tuple (List.map args ~f:to_dyn)
+    | `Null -> Dyn.Variant ("Null", [])
+    | `Variant (name, Some arg) -> Variant (name, [ to_dyn arg ])
+    | `Variant (name, None) -> Variant (name, [])
+    | `Intlit s -> String s
+  ;;
+end
+
+module Log = struct
+  let level : (string option -> bool) ref = ref (fun _ -> false)
+  let out = ref Format.err_formatter
+
+  type message =
+    { message : string
+    ; payload : (string * Json.t) list
+    }
+
+  let msg message payload = { message; payload }
+
+  let log ?section k =
+    if !level section
+    then (
+      let message = k () in
+      (match section with
+       | None -> Format.fprintf !out "%s@." message.message
+       | Some section -> Format.fprintf !out "[%s] %s@." section message.message);
+      (match message.payload with
+       | [] -> ()
+       | fields -> Format.fprintf !out "%a@." Json.pp (`Assoc fields));
+      Format.pp_print_flush !out ())
+  ;;
+end
+
+let sprintf = Printf.sprintf
+
+module Types = Lsp.Types
+module Client_request = Lsp.Client_request
+module Server_request = Lsp.Server_request
+module Server_notification = Lsp.Server_notification
+module Client_notification = Lsp.Client_notification
+
+module Jrpc_id = struct
+  include Jsonrpc.Id
+
+  let to_dyn = function
+    | `String s -> Dyn.String s
+    | `Int i -> Dyn.Int i
+  ;;
+end

thirdparty/lsp/lsp-fiber/src/lazy_fiber.ml

@@ -0,0 +1,18 @@
+type 'a t =
+  { value : 'a Fiber.Ivar.t
+  ; mutable f : (unit -> 'a Fiber.t) option
+  }
+
+let create f = { f = Some f; value = Fiber.Ivar.create () }
+
+let force t =
+  let open Fiber.O in
+  match t.f with
+  | None -> Fiber.Ivar.read t.value
+  | Some f ->
+    Fiber.of_thunk (fun () ->
+      t.f <- None;
+      let* v = f () in
+      let+ () = Fiber.Ivar.fill t.value v in
+      v)
+;;

thirdparty/lsp/lsp-fiber/src/lazy_fiber.mli

@@ -0,0 +1,4 @@
+type 'a t
+
+val create : (unit -> 'a Fiber.t) -> 'a t
+val force : 'a t -> 'a Fiber.t

thirdparty/lsp/lsp-fiber/src/lsp_fiber.ml

@@ -0,0 +1,11 @@
+module Fiber_io = Fiber_io
+module Lazy_fiber = Lazy_fiber
+module Rpc = Rpc
+module Client = Client
+module Server = Server
+module Json = Import.Json
+
+module Private = struct
+  module Log = Import.Log
+  module Fdecl = Import.Fdecl
+end

thirdparty/lsp/lsp-fiber/src/rpc.ml

@@ -0,0 +1,450 @@
+open Import
+open Fiber.O
+module Id = Jsonrpc.Id
+module Response = Jsonrpc.Response
+module Session = Jsonrpc_fiber.Make (Fiber_io)
+
+module Reply = struct
+  type 'r t =
+    | Now of 'r
+    | Later of (('r -> unit Fiber.t) -> unit Fiber.t)
+
+  let now r = Now r
+  let later f = Later f
+end
+
+let cancel_token = Fiber.Var.create ()
+
+module State = struct
+  type t =
+    | Waiting_for_init
+    | Running
+    | Closed
+end
+
+module type S = sig
+  type 'a out_request
+  type out_notification
+  type 'a in_request
+  type in_notification
+  type 'state t
+
+  module Handler : sig
+    type 'a session := 'a t
+
+    type 'state on_request =
+      { on_request : 'a. 'state session -> 'a in_request -> ('a Reply.t * 'state) Fiber.t
+      }
+
+    type 'state t
+
+    val make
+      :  ?on_request:'state on_request
+      -> ?on_notification:('state session -> in_notification -> 'state Fiber.t)
+      -> unit
+      -> 'state t
+  end
+
+  val state : 'a t -> 'a
+  val make : 'state Handler.t -> Fiber_io.t -> 'state -> 'state t
+  val stop : _ t -> unit Fiber.t
+  val request : _ t -> 'resp out_request -> 'resp Fiber.t
+  val notification : _ t -> out_notification -> unit Fiber.t
+  val cancel_token : unit -> Fiber.Cancel.t option Fiber.t
+
+  module Batch : sig
+    type 'a session := 'a t
+    type t
+
+    val create : _ session -> t
+    val notification : t -> out_notification -> unit
+
+    type 'a response
+
+    val await : 'a response -> 'a Fiber.t
+    val request : t -> 'resp out_request -> 'resp response
+    val submit : t -> unit Fiber.t
+  end
+end
+
+module type Request_intf = sig
+  type 'a t
+  type packed = E : 'r t -> packed
+
+  val of_jsonrpc : Jsonrpc.Request.t -> (packed, string) result
+  val yojson_of_result : 'a t -> 'a -> Json.t
+  val to_jsonrpc_request : 'a t -> id:Id.t -> Jsonrpc.Request.t
+  val response_of_json : 'a t -> Json.t -> 'a
+end
+
+module type Notification_intf = sig
+  type t
+
+  val of_jsonrpc : Jsonrpc.Notification.t -> (t, string) result
+  val to_jsonrpc : t -> Jsonrpc.Notification.t
+end
+
+module Table = Stdlib.Hashtbl.Make (Jsonrpc.Id)
+
+module Make
+    (Initialize : sig
+       type t
+     end)
+    (Out_request : Request_intf)
+    (Out_notification : Notification_intf)
+    (In_request : Request_intf)
+    (In_notification : Notification_intf) =
+struct
+  type 'a out_request = 'a Out_request.t
+  type 'a in_request = 'a In_request.t
+  type out_notification = Out_notification.t
+  type in_notification = In_notification.t
+
+  type 'state t =
+    { io : Fiber_io.t
+    ; (* mutable only to initialiaze this record *)
+      mutable session : 'state Session.t Fdecl.t
+    ; (* Internal state of the session *)
+      mutable state : State.t
+    ; (* Filled when the server is initialied *)
+      initialized : Initialize.t Fiber.Ivar.t
+    ; mutable req_id : int
+    ; pending : Fiber.Cancel.t Table.t
+    ; detached : Fiber.Pool.t
+    }
+
+  and 'state on_request =
+    { on_request : 'a. 'state t -> 'a in_request -> ('a Reply.t * 'state) Fiber.t }
+
+  and 'state handler =
+    { h_on_request : 'state on_request
+    ; h_on_notification : 'state t -> In_notification.t -> 'state Fiber.t
+    }
+
+  module Handler = struct
+    type nonrec 'state on_request = 'state on_request =
+      { on_request : 'a. 'state t -> 'a in_request -> ('a Reply.t * 'state) Fiber.t }
+
+    type nonrec 'state t = 'state handler =
+      { h_on_request : 'state on_request
+      ; h_on_notification : 'state t -> In_notification.t -> 'state Fiber.t
+      }
+
+    let on_notification_default _ notification =
+      Format.eprintf "dropped notification@.%!";
+      let notification = In_notification.to_jsonrpc notification in
+      Code_error.raise
+        "unexpected notification"
+        [ "notification", Json.to_dyn (Jsonrpc.Notification.yojson_of_t notification) ]
+    ;;
+
+    let on_request_default =
+      { on_request =
+          (fun _ _ ->
+            Jsonrpc.Response.Error.make ~code:InternalError ~message:"Not supported" ()
+            |> Jsonrpc.Response.Error.raise)
+      }
+    ;;
+
+    let make
+          ?(on_request = on_request_default)
+          ?(on_notification = on_notification_default)
+          ()
+      =
+      { h_on_request = on_request; h_on_notification = on_notification }
+    ;;
+  end
+
+  let state t = Session.state (Fdecl.get t.session)
+
+  let to_jsonrpc (type state) (t : state t) h_on_request h_on_notification =
+    let on_request (ctx : (state, Jsonrpc.Request.t) Session.Context.t) =
+      let req = Session.Context.message ctx in
+      let state = Session.Context.state ctx in
+      match In_request.of_jsonrpc req with
+      | Error message ->
+        let code = Jsonrpc.Response.Error.Code.InvalidParams in
+        let error = Jsonrpc.Response.Error.make ~code ~message () in
+        Fiber.return (Jsonrpc_fiber.Reply.now (Jsonrpc.Response.error req.id error), state)
+      | Ok (In_request.E r) ->
+        let cancel = Fiber.Cancel.create () in
+        let remove = lazy (Table.remove t.pending req.id) in
+        let+ response, state =
+          Fiber.with_error_handler
+            ~on_error:
+              (Stdune.Exn_with_backtrace.map_and_reraise ~f:(fun exn ->
+                 Lazy.force remove;
+                 exn))
+            (fun () ->
+               Fiber.Var.set cancel_token cancel (fun () ->
+                 Table.replace t.pending req.id cancel;
+                 h_on_request.on_request t r))
+        in
+        let to_response x =
+          Jsonrpc.Response.ok req.id (In_request.yojson_of_result r x)
+        in
+        let reply =
+          match response with
+          | Reply.Now r ->
+            Lazy.force remove;
+            Jsonrpc_fiber.Reply.now (to_response r)
+          | Reply.Later k ->
+            let f send =
+              Fiber.finalize
+                (fun () ->
+                   Fiber.Var.set cancel_token cancel (fun () ->
+                     k (fun r -> send (to_response r))))
+                ~finally:(fun () ->
+                  Lazy.force remove;
+                  Fiber.return ())
+            in
+            Jsonrpc_fiber.Reply.later f
+        in
+        reply, state
+    in
+    let on_notification ctx =
+      let r = Session.Context.message ctx in
+      match In_notification.of_jsonrpc r with
+      | Ok r -> h_on_notification t r
+      | Error error ->
+        Log.log ~section:"lsp" (fun () ->
+          Log.msg "Invalid notification" [ "error", `String error ]);
+        let state = Session.Context.state ctx in
+        Fiber.return (Jsonrpc_fiber.Notify.Continue, state)
+    in
+    on_request, on_notification
+  ;;
+
+  let make ~name h_on_request h_on_notification io state =
+    let t =
+      { io
+      ; state = Waiting_for_init
+      ; session = Fdecl.create ()
+      ; initialized = Fiber.Ivar.create ()
+      ; req_id = 1
+      ; pending = Table.create 32
+      ; detached = Fiber.Pool.create ()
+      }
+    in
+    let session =
+      let on_request, on_notification = to_jsonrpc t h_on_request h_on_notification in
+      Session.create ~on_request ~on_notification ~name io state
+    in
+    Fdecl.set t.session session;
+    t
+  ;;
+
+  let create_request t req =
+    let id = `Int t.req_id in
+    t.req_id <- t.req_id + 1;
+    Out_request.to_jsonrpc_request req ~id
+  ;;
+
+  let receive_response req (resp : Jsonrpc.Response.t) =
+    match resp.result |> Result.map (Out_request.response_of_json req) with
+    | Ok s -> s
+    | Error e -> raise (Jsonrpc.Response.Error.E e)
+  ;;
+
+  let request (type r) (t : _ t) (req : r Out_request.t) : r Fiber.t =
+    Fiber.of_thunk (fun () ->
+      let+ resp =
+        let req = create_request t req in
+        Session.request (Fdecl.get t.session) req
+      in
+      receive_response req resp)
+  ;;
+
+  let request_with_cancel (type r) (t : _ t) cancel ~on_cancel (req : r Out_request.t)
+    : [ `Ok of r | `Cancelled ] Fiber.t
+    =
+    let* () = Fiber.return () in
+    let jsonrpc_req = create_request t req in
+    let+ resp, cancel_status =
+      Fiber.Cancel.with_handler
+        cancel
+        ~on_cancel:(fun () -> on_cancel jsonrpc_req.id)
+        (fun () ->
+           let+ resp = Session.request (Fdecl.get t.session) jsonrpc_req in
+           match resp.result with
+           | Error { code = RequestCancelled; _ } -> `Cancelled
+           | Ok _ when Fiber.Cancel.fired cancel -> `Cancelled
+           | Ok s -> `Ok (Out_request.response_of_json req s)
+           | Error e -> raise (Jsonrpc.Response.Error.E e))
+    in
+    match cancel_status with
+    | Cancelled () -> `Cancelled
+    | Not_cancelled ->
+      (match resp with
+       | `Ok resp -> `Ok resp
+       | `Cancelled -> assert false)
+  ;;
+
+  let notification (t : _ t) (n : Out_notification.t) : unit Fiber.t =
+    let jsonrpc_request = Out_notification.to_jsonrpc n in
+    Session.notification (Fdecl.get t.session) jsonrpc_request
+  ;;
+
+  module Batch = struct
+    type session = E : 'a t -> session
+
+    type t =
+      { batch : Session.Batch.t
+      ; session : session
+      }
+
+    let create session = { batch = Session.Batch.create (); session = E session }
+
+    let notification t n =
+      let n = Out_notification.to_jsonrpc n in
+      Session.Batch.notification t.batch n
+    ;;
+
+    type 'a response = 'a Lazy_fiber.t
+
+    let await req = Lazy_fiber.force req
+
+    let request (type r) (t : t) (req : r Out_request.t) : r response =
+      let (E session) = t.session in
+      let response =
+        let req = create_request session req in
+        Session.Batch.request t.batch req
+      in
+      Lazy_fiber.create (fun () ->
+        let+ response = Session.Batch.await response in
+        receive_response req response)
+    ;;
+
+    let submit { session = E session; batch } =
+      let t = Fdecl.get session.session in
+      Session.submit t batch
+    ;;
+  end
+
+  let initialized t = Fiber.Ivar.read t.initialized
+
+  let stop t =
+    let+ () = Session.stop (Fdecl.get t.session) in
+    t.state <- Closed
+  ;;
+
+  let start_loop t =
+    Fiber.fork_and_join_unit
+      (fun () ->
+         let* () = Session.run (Fdecl.get t.session) in
+         Fiber.Pool.stop t.detached)
+      (fun () -> Fiber.Pool.run t.detached)
+  ;;
+
+  let handle_cancel_req t id =
+    let+ () =
+      match Table.find_opt t.pending id with
+      | None -> Fiber.return ()
+      | Some token -> Fiber.Pool.task t.detached ~f:(fun () -> Fiber.Cancel.fire token)
+    in
+    Jsonrpc_fiber.Notify.Continue, state t
+  ;;
+
+  let cancel_token () = Fiber.Var.get cancel_token
+end
+
+module Client = struct
+  open Types
+
+  include
+    Make (InitializeResult) (Client_request) (Client_notification) (Server_request)
+      (Server_notification)
+
+  let h_on_notification handler t n =
+    match n with
+    | Server_notification.CancelRequest id -> handle_cancel_req t id
+    | _ ->
+      let+ res = handler.h_on_notification t n in
+      Jsonrpc_fiber.Notify.Continue, res
+  ;;
+
+  let make handler io =
+    let h_on_notification = h_on_notification handler in
+    make ~name:"client" handler.h_on_request h_on_notification io
+  ;;
+
+  let request_with_cancel t cancel r =
+    request_with_cancel t cancel r ~on_cancel:(fun id ->
+      notification t (Client_notification.CancelRequest id))
+  ;;
+
+  let start (t : _ t) (p : InitializeParams.t) =
+    Fiber.of_thunk (fun () ->
+      assert (t.state = Waiting_for_init);
+      let loop () = start_loop t in
+      let init () =
+        let* resp = request t (Client_request.Initialize p) in
+        Log.log ~section:"client" (fun () ->
+          let resp = InitializeResult.yojson_of_t resp in
+          Log.msg "initialized" [ "resp", resp ]);
+        t.state <- Running;
+        Fiber.Ivar.fill t.initialized resp
+      in
+      Fiber.fork_and_join_unit loop init)
+  ;;
+end
+
+module Server = struct
+  open Types
+
+  include
+    Make (InitializeParams) (Server_request) (Server_notification) (Client_request)
+      (Client_notification)
+
+  let h_on_notification handler t n =
+    Fiber.of_thunk (fun () ->
+      match n with
+      | Client_notification.Exit ->
+        Log.log ~section:"server" (fun () -> Log.msg "received exit notification" []);
+        let* () = stop t in
+        Fiber.return (Jsonrpc_fiber.Notify.Stop, state t)
+      | Client_notification.CancelRequest id -> handle_cancel_req t id
+      | _ ->
+        if t.state = Waiting_for_init
+        then (
+          let state = state t in
+          Fiber.return (Jsonrpc_fiber.Notify.Continue, state))
+        else
+          let+ state = handler.h_on_notification t n in
+          Jsonrpc_fiber.Notify.Continue, state)
+  ;;
+
+  let on_request handler t in_r =
+    Fiber.of_thunk (fun () ->
+      match Client_request.E in_r with
+      | Client_request.E (Client_request.Initialize i) ->
+        if t.state = Waiting_for_init
+        then (
+          let* result = handler.h_on_request.on_request t in_r in
+          t.state <- Running;
+          (* XXX Should we wait for the waiter of initialized to finish? *)
+          let* () = Fiber.Ivar.fill t.initialized i in
+          Fiber.return result)
+        else (
+          let code = Response.Error.Code.InvalidRequest in
+          let message = "already initialized" in
+          raise (Jsonrpc.Response.Error.E (Jsonrpc.Response.Error.make ~code ~message ())))
+      | Client_request.E _ ->
+        if t.state = Waiting_for_init
+        then (
+          let code = Response.Error.Code.ServerNotInitialized in
+          let message = "not initialized" in
+          raise (Jsonrpc.Response.Error.E (Jsonrpc.Response.Error.make ~code ~message ())))
+        else handler.h_on_request.on_request t in_r)
+  ;;
+
+  let make (type s) (handler : s Handler.t) io (initial_state : s) =
+    let h_on_request : _ Handler.on_request =
+      { Handler.on_request = (fun t x -> on_request handler t x) }
+    in
+    let h_on_notification = h_on_notification handler in
+    make ~name:"server" h_on_request h_on_notification io initial_state
+  ;;
+
+  let start t = start_loop t
+end

thirdparty/lsp/lsp-fiber/src/rpc.mli

@@ -0,0 +1,91 @@
+(** * This encodes LSP RPC state machine. *)
+
+open! Import
+
+module Reply : sig
+  type 'resp t
+
+  val now : 'r -> 'r t
+  val later : (('r -> unit Fiber.t) -> unit Fiber.t) -> 'r t
+end
+
+module type S = sig
+  type 'a out_request
+  type out_notification
+  type 'a in_request
+  type in_notification
+  type 'state t
+
+  module Handler : sig
+    type 'a session := 'a t
+
+    type 'state on_request =
+      { on_request : 'a. 'state session -> 'a in_request -> ('a Reply.t * 'state) Fiber.t
+      }
+
+    type 'state t
+
+    val make
+      :  ?on_request:'state on_request
+      -> ?on_notification:('state session -> in_notification -> 'state Fiber.t)
+      -> unit
+      -> 'state t
+  end
+
+  val state : 'a t -> 'a
+  val make : 'state Handler.t -> Fiber_io.t -> 'state -> 'state t
+  val stop : 'state t -> unit Fiber.t
+  val request : _ t -> 'resp out_request -> 'resp Fiber.t
+  val notification : _ t -> out_notification -> unit Fiber.t
+
+  (** only available inside requests *)
+  val cancel_token : unit -> Fiber.Cancel.t option Fiber.t
+
+  module Batch : sig
+    type 'a session := 'a t
+    type t
+
+    val create : _ session -> t
+    val notification : t -> out_notification -> unit
+
+    type 'a response
+
+    val await : 'a response -> 'a Fiber.t
+    val request : t -> 'resp out_request -> 'resp response
+    val submit : t -> unit Fiber.t
+  end
+end
+
+module Client : sig
+  open Types
+
+  include
+    S
+    with type 'a out_request = 'a Client_request.t
+     and type out_notification = Client_notification.t
+     and type 'a in_request = 'a Server_request.t
+     and type in_notification = Server_notification.t
+
+  val request_with_cancel
+    :  _ t
+    -> Fiber.Cancel.t
+    -> 'resp out_request
+    -> [ `Ok of 'resp | `Cancelled ] Fiber.t
+
+  val initialized : _ t -> InitializeResult.t Fiber.t
+  val start : _ t -> InitializeParams.t -> unit Fiber.t
+end
+
+module Server : sig
+  open Types
+
+  include
+    S
+    with type 'a out_request = 'a Server_request.t
+     and type out_notification = Server_notification.t
+     and type 'a in_request = 'a Client_request.t
+     and type in_notification = Client_notification.t
+
+  val initialized : _ t -> InitializeParams.t Fiber.t
+  val start : _ t -> unit Fiber.t
+end

thirdparty/lsp/lsp-fiber/src/server.ml

@@ -0,0 +1 @@
+include Rpc.Server

thirdparty/lsp/lsp-fiber/src/server.mli

@@ -0,0 +1,2 @@
+open! Import
+include module type of Rpc.Server

thirdparty/lsp/lsp-fiber/test/dune

@@ -0,0 +1,29 @@
+; we cannot use the normal test alias because cinaps overtakes it
+
+(library
+ (name lsp_fiber_tests)
+ (inline_tests)
+ (preprocess
+  (pps ppx_expect))
+ (enabled_if
+  (>= %{ocaml_version} 4.08))
+ (libraries
+  base
+  fiber
+  fiber_test
+  lev
+  lev_fiber
+  jsonrpc
+  jsonrpc_fiber
+  lsp
+  lsp_fiber
+  ;; This is because of the (implicit_transitive_deps false)
+  ;; in dune-project
+  ppx_expect
+  ppx_expect.config
+  ppx_expect.config_types
+  ppx_inline_test.config
+  ppx_yojson_conv_lib
+  stdune
+  threads.posix
+  yojson))

thirdparty/lsp/lsp-fiber/test/lsp_fiber_test.ml

@@ -0,0 +1,223 @@
+open Fiber.O
+open Lsp
+open Lsp.Types
+open Lsp_fiber
+
+module Test = struct
+  module Client = struct
+    let run
+          ?(capabilities = ClientCapabilities.create ())
+          ?on_request
+          ?on_notification
+          state
+          (in_, out)
+      =
+      let initialize = InitializeParams.create ~capabilities () in
+      let client =
+        let stream_io = Lsp_fiber.Fiber_io.make in_ out in
+        let handler = Client.Handler.make ?on_request ?on_notification () in
+        Client.make handler stream_io state
+      in
+      client, Client.start client initialize
+    ;;
+  end
+
+  module Server = struct
+    let run ?on_request ?on_notification state (in_, out) =
+      let server =
+        let stream_io = Fiber_io.make in_ out in
+        let handler = Server.Handler.make ?on_request ?on_notification () in
+        Server.make handler stream_io state
+      in
+      server, Server.start server
+    ;;
+  end
+end
+
+let pipe () = Lev_fiber.Io.pipe ~cloexec:true ()
+
+let test make_client make_server =
+  Printexc.record_backtrace false;
+  let run () =
+    let* client_in, server_out = pipe () in
+    let* server_in, client_out = pipe () in
+    let server () = make_server (server_in, server_out) in
+    let client () = make_client (client_in, client_out) in
+    let+ () = Fiber.fork_and_join_unit server client in
+    print_endline "Successful termination of test"
+  in
+  Lev_fiber.run run |> Lev_fiber.Error.ok_exn;
+  print_endline "[TEST] finished"
+;;
+
+let json_pp = Yojson.Safe.pretty_print ~std:false
+
+module End_to_end_client = struct
+  let on_request (type a) _ (_ : a Server_request.t) =
+    Jsonrpc.Response.Error.raise
+      (Jsonrpc.Response.Error.make ~message:"not implemented" ~code:InternalError ())
+  ;;
+
+  let on_notification (client : _ Client.t) n =
+    let state = Client.state client in
+    let received_notification = state in
+    let req = Server_notification.to_jsonrpc n in
+    Format.eprintf
+      "client: received notification@.%a@.%!"
+      json_pp
+      (Jsonrpc.Notification.yojson_of_t req);
+    let+ () = Fiber.Ivar.fill received_notification () in
+    Format.eprintf "client: filled received_notification@.%!";
+    state
+  ;;
+
+  let run io =
+    let detached = Fiber.Pool.create () in
+    let received_notification = Fiber.Ivar.create () in
+    let client, running =
+      let on_request = { Client.Handler.on_request } in
+      Test.Client.run ~on_request ~on_notification received_notification io
+    in
+    let init () : unit Fiber.t =
+      Format.eprintf "client: waiting for initialization@.%!";
+      let* (_ : InitializeResult.t) = Client.initialized client in
+      Format.eprintf "client: server initialized. sending request@.%!";
+      let cancel = Fiber.Cancel.create () in
+      let* () =
+        Fiber.Pool.task detached ~f:(fun () ->
+          Format.eprintf
+            "client: waiting to receive notification before cancelling the request@.%!";
+          let* () = Fiber.Ivar.read received_notification in
+          Format.eprintf "client: received notification, cancelling the request@.%!";
+          Fiber.Cancel.fire cancel)
+      in
+      let* res_cancel =
+        let req_cancel =
+          Client_request.ExecuteCommand
+            (ExecuteCommandParams.create ~command:"cmd_cancel" ())
+        in
+        Format.eprintf "client: sending request cmd_cancel@.%!";
+        Client.request_with_cancel client cancel req_cancel
+      and* res_reply =
+        let req_reply =
+          Client_request.ExecuteCommand
+            (ExecuteCommandParams.create ~command:"cmd_reply" ())
+        in
+        Format.eprintf "client: sending request cmd_reply@.%!";
+        Client.request client req_reply
+      in
+      (match res_cancel with
+       | `Cancelled -> Format.eprintf "client: req_cancel got cancelled@.%!"
+       | `Ok _ -> assert false);
+      Format.eprintf
+        "client: Successfully executed req_reply with result:@.%a@."
+        json_pp
+        res_reply;
+      Format.eprintf "client: sending request to shutdown@.%!";
+      let* () = Fiber.Pool.stop detached in
+      Client.notification client Exit
+    in
+    Fiber.fork_and_join_unit init (fun () ->
+      Fiber.fork_and_join_unit (fun () -> running) (fun () -> Fiber.Pool.run detached))
+  ;;
+end
+
+module End_to_end_server = struct
+  type status =
+    | Started
+    | Initialized
+
+  let on_request =
+    let on_request (type a) self (req : a Client_request.t) : (a Rpc.Reply.t * _) Fiber.t =
+      let state = Server.state self in
+      let _status, detached = state in
+      match req with
+      | Client_request.Initialize _ ->
+        let capabilities = ServerCapabilities.create () in
+        let result = InitializeResult.create ~capabilities () in
+        Format.eprintf "server: initializing server@.";
+        Format.eprintf "server: returning initialization result@.%!";
+        Fiber.return (Rpc.Reply.now result, (Initialized, detached))
+      | Client_request.ExecuteCommand { command; _ } ->
+        Format.eprintf "server: received command %s@.%!" command;
+        let* () =
+          match command with
+          | "cmd_cancel" ->
+            Fiber.Pool.task detached ~f:(fun () ->
+              Format.eprintf "server: sending message notification to client@.%!";
+              let msg =
+                ShowMessageParams.create
+                  ~type_:MessageType.Info
+                  ~message:"notifying client"
+              in
+              Server.notification self (Server_notification.ShowMessage msg))
+          | _ -> Fiber.return ()
+        in
+        let* () = Fiber.Pool.stop detached in
+        let result = `String "successful execution" in
+        let* cancel = Rpc.Server.cancel_token () in
+        (match command with
+         | "cmd_cancel" ->
+           let+ () = Lev_fiber.Timer.sleepf 0.2 in
+           ( Rpc.Reply.later (fun k ->
+               let* cancel = Rpc.Server.cancel_token () in
+               (* Make sure that we can access the cancel token in a Reply
+                  response *)
+               assert (Option.is_some cancel);
+               k result)
+           , state )
+         | _ ->
+           (* Make sure that we can access the cancel token in a Now response *)
+           assert (Option.is_some cancel);
+           Fiber.return (Rpc.Reply.now result, state))
+      | _ ->
+        Jsonrpc.Response.Error.raise
+          (Jsonrpc.Response.Error.make ~code:InternalError ~message:"not supported" ())
+    in
+    { Server.Handler.on_request }
+  ;;
+
+  let on_notification self _ =
+    let state = Server.state self in
+    Format.eprintf "server: Received notification@.%!";
+    Fiber.return state
+  ;;
+
+  let run io =
+    let detached = Fiber.Pool.create () in
+    let _server, running =
+      Test.Server.run ~on_request ~on_notification (Started, detached) io
+    in
+    Fiber.fork_and_join_unit (fun () -> running) (fun () -> Fiber.Pool.run detached)
+  ;;
+end
+
+let%expect_test "end to end run of lsp tests" =
+  test End_to_end_client.run End_to_end_server.run;
+  [%expect
+    {|
+    client: waiting for initialization
+    server: initializing server
+    server: returning initialization result
+    client: server initialized. sending request
+    client: sending request cmd_cancel
+    client: sending request cmd_reply
+    client: waiting to receive notification before cancelling the request
+    server: received command cmd_cancel
+    server: sending message notification to client
+    client: received notification
+    {
+      "params": { "message": "notifying client", "type": 3 },
+      "method": "window/showMessage",
+      "jsonrpc": "2.0"
+    }
+    client: filled received_notification
+    client: received notification, cancelling the request
+    server: received command cmd_reply
+    client: req_cancel got cancelled
+    client: Successfully executed req_reply with result:
+    "successful execution"
+    client: sending request to shutdown
+    Successful termination of test
+    [TEST] finished |}]
+;;

thirdparty/lsp/lsp.opam

@@ -0,0 +1,52 @@
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+synopsis: "LSP protocol implementation in OCaml"
+description: """
+
+Implementation of the LSP protocol in OCaml. It is designed to be as portable as
+possible and does not make any assumptions about IO.
+"""
+maintainer: ["Rudi Grinberg <me@rgrinberg.com>"]
+authors: [
+  "Andrey Popp <8mayday@gmail.com>"
+  "Rusty Key <iam@stfoo.ru>"
+  "Louis Roché <louis@louisroche.net>"
+  "Oleksiy Golovko <alexei.golovko@gmail.com>"
+  "Rudi Grinberg <me@rgrinberg.com>"
+  "Sacha Ayoun <sachaayoun@gmail.com>"
+  "cannorin <cannorin@gmail.com>"
+  "Ulugbek Abdullaev <ulugbekna@gmail.com>"
+  "Thibaut Mattio <thibaut.mattio@gmail.com>"
+  "Max Lantas <mnxndev@outlook.com>"
+]
+license: "ISC"
+homepage: "https://github.com/ocaml/ocaml-lsp"
+bug-reports: "https://github.com/ocaml/ocaml-lsp/issues"
+depends: [
+  "dune" {>= "3.0"}
+  "jsonrpc" {= version}
+  "yojson"
+  "ppx_yojson_conv_lib" {>= "v0.14"}
+  "cinaps" {with-test}
+  "ppx_expect" {>= "v0.17.0" & with-test}
+  "uutf" {>= "1.0.2"}
+  "odoc" {with-doc}
+  "ocaml" {>= "4.14"}
+  "ppx_yojson_conv" {with-dev-setup}
+]
+dev-repo: "git+https://github.com/ocaml/ocaml-lsp.git"
+build: [
+  ["dune" "subst"] {dev}
+  [
+    "dune"
+    "build"
+    "-p"
+    name
+    "-j"
+    jobs
+    "@install"
+    "@doc" {with-doc}
+  ]
+]
+
+x-maintenance-intent: [ "(latest)" "(latest)-414" ]

thirdparty/lsp/lsp.opam.template

@@ -0,0 +1,15 @@
+build: [
+  ["dune" "subst"] {dev}
+  [
+    "dune"
+    "build"
+    "-p"
+    name
+    "-j"
+    jobs
+    "@install"
+    "@doc" {with-doc}
+  ]
+]
+
+x-maintenance-intent: [ "(latest)" "(latest)-414" ]

thirdparty/lsp/lsp/bin/cinaps.ml

@@ -0,0 +1,178 @@
+open Import
+
+let preprocess_metamodel =
+  object (self)
+    inherit Metamodel.map as super
+
+    method! or_ path (types : Metamodel.type_ list) =
+      match
+        List.filter_map types ~f:(function
+          | Literal (Record []) -> None
+          | _ as t -> Some (self#type_ path t))
+      with
+      | [] -> assert false
+      | [ t ] -> t
+      | [ Metamodel.Literal (Record f1); Literal (Record f2) ] as ts ->
+        (match path with
+         | Top (Alias s) when s.name = "TextDocumentContentChangeEvent" ->
+           let t =
+             let union_fields l1 l2 ~f =
+               let of_map =
+                 String.Map.of_list_map_exn ~f:(fun (x : Metamodel.property) -> x.name, x)
+               in
+               String.Map.merge (of_map l1) (of_map l2) ~f |> String.Map.values
+             in
+             union_fields f1 f2 ~f:(fun k t1 t2 ->
+               if k = "text"
+               then t1
+               else if k = "range"
+               then (
+                 match t1, t2 with
+                 | None, Some s | Some s, None ->
+                   assert (not s.optional);
+                   Some { s with optional = true }
+                 | None, None | Some _, Some _ -> assert false)
+               else (
+                 match t1, t2 with
+                 | None, None -> assert false
+                 | Some s, None | None, Some s -> Some s
+                 | Some _, Some _ -> assert false))
+           in
+           self#type_ path (Metamodel.Literal (Record t))
+         | _ -> super#or_ path ts)
+      | ts -> super#or_ path ts
+
+    method! property path (p : Metamodel.property) =
+      let update_type type_ =
+        let type_ = self#type_ path type_ in
+        super#property path { p with type_ }
+      in
+      let open Metamodel.Path in
+      match path with
+      | Top (Structure s)
+        when p.name = "trace"
+             && (s.name = "_InitializeParams" || s.name = "InitializeParams") ->
+        update_type (Reference "TraceValues")
+      | Top (Structure s) when p.name = "location" && s.name = "WorkspaceSymbol" ->
+        (match p.type_ with
+         | Or [ type_; _ ] -> update_type type_
+         | _ -> assert false)
+      | _ -> super#property path p
+
+    method! enumeration m =
+      match m.name = "TraceValues" with
+      | false -> super#enumeration m
+      | true ->
+        super#enumeration
+          (let values =
+             let compact : Metamodel.enumerationEntry =
+               { name = "Compact"
+               ; value = `String "compact"
+               ; doc = { since = None; documentation = None }
+               }
+             in
+             compact :: m.values
+           in
+           { m with values })
+  end
+;;
+
+let expand_superclasses db (m : Metamodel.t) =
+  let structures =
+    let uniquify_fields fields =
+      List.fold_left fields ~init:String.Map.empty ~f:(fun acc (f : Metamodel.property) ->
+        String.Map.set acc f.name f)
+      |> String.Map.values
+    in
+    let rec fields_of_type (t : Metamodel.type_) =
+      match t with
+      | Reference s ->
+        (match Metamodel.Entity.DB.find db s with
+         | Structure s -> fields_of_structure s
+         | Enumeration _ -> assert false
+         | Alias a -> fields_of_type a.type_)
+      | _ -> assert false
+    and fields_of_structure (s : Metamodel.structure) =
+      let fields = List.map (s.extends @ s.mixins) ~f:fields_of_type @ [ s.properties ] in
+      List.concat fields
+    in
+    List.map m.structures ~f:(fun s ->
+      let properties = fields_of_structure s |> uniquify_fields in
+      { s with properties })
+  in
+  { m with structures }
+;;
+
+let ocaml =
+  lazy
+    (Metamodel_lsp.t ()
+     |> preprocess_metamodel#t
+     |> (fun metamodel ->
+     let db = Metamodel.Entity.DB.create metamodel in
+     expand_superclasses db metamodel)
+     |> Typescript.of_metamodel
+     |> Ocaml.of_typescript)
+;;
+
+module Output = struct
+  open Ocaml
+
+  type t =
+    { mutable modules : Module.t list
+    ; kind : Ml.Kind.t
+    ; out : out_channel
+    }
+
+  let create modules kind out_channel = { modules; out = out_channel; kind }
+
+  let module_name (t : t) (m : Module.t) =
+    match t.kind with
+    | Intf -> (m.intf.name :> string)
+    | Impl -> (m.impl.name :> string)
+  ;;
+
+  let _skip (t : t) name =
+    match t.modules with
+    | [] -> failwith "non left to skip"
+    | m :: modules ->
+      let name' = module_name t m in
+      assert (String.equal name name');
+      t.modules <- modules
+  ;;
+
+  let pp_file pp ch =
+    let fmt = Format.formatter_of_out_channel ch in
+    Pp.to_fmt fmt pp;
+    Format.pp_print_flush fmt ()
+  ;;
+
+  let write t cmd =
+    let to_write, modules =
+      match cmd with
+      | `Finish -> t.modules, []
+      | `Until m ->
+        let rec loop xs acc =
+          match xs with
+          | [] -> List.rev acc, []
+          | x :: xs ->
+            if module_name t x = m then List.rev acc, x :: xs else loop xs (x :: acc)
+        in
+        loop t.modules []
+    in
+    t.modules <- modules;
+    List.iter to_write ~f:(fun m ->
+      let pp = Module.pp m in
+      let pp = Ml.Kind.Map.get pp t.kind in
+      pp_file pp t.out)
+  ;;
+end
+
+let print_ml () =
+  let output = Output.create (Lazy.force ocaml) Ml.Kind.Impl stdout in
+  Output.write output `Finish
+;;
+
+let print_mli () =
+  let output = Output.create (Lazy.force ocaml) Ml.Kind.Intf stdout in
+  Output.write output `Finish
+;;

thirdparty/lsp/lsp/bin/cinaps.mli

@@ -0,0 +1,2 @@
+val print_ml : unit -> unit
+val print_mli : unit -> unit

thirdparty/lsp/lsp/bin/dune

@@ -0,0 +1,16 @@
+(include_subdirs unqualified)
+
+(test
+ (name test_metamodel)
+ (modules test_metamodel)
+ (libraries stdune yojson lsp_gen)
+ (deps metamodel/metaModel.json)
+ (action
+  (run ./test_metamodel.exe %{deps})))
+
+(library
+ (name lsp_gen)
+ (instrumentation
+  (backend bisect_ppx))
+ (modules :standard \ test_metamodel)
+ (libraries stdune dyn pp yojson))

thirdparty/lsp/lsp/bin/import.ml

@@ -0,0 +1,13 @@
+include struct
+  open Stdune
+  module List = List
+  module Id = Id
+  module String = String
+  module Code_error = Code_error
+  module Comparable = Comparable
+  module Top_closure = Top_closure
+  module Poly = Poly
+  module Option = Option
+
+  let sprintf = sprintf
+end

thirdparty/lsp/lsp/bin/lsp_gen.ml

@@ -0,0 +1,7 @@
+module Typescript = Typescript
+module Ocaml = Ocaml
+module Cinaps = Cinaps
+module Metamodel = Metamodel
+
+let print_ml = Cinaps.print_ml
+let print_mli = Cinaps.print_mli

thirdparty/lsp/lsp/bin/metamodel/dune

@@ -0,0 +1,9 @@
+; get rid of this gross hack once dune has proper crunch support
+
+(rule
+ (with-stdout-to
+  metamodel_lsp.ml
+  (progn
+   (echo "let t () = Metamodel.t @@ Yojson.Safe.from_string {json|")
+   (echo "%{read:metaModel.json}")
+   (echo "|json}"))))

thirdparty/lsp/lsp/bin/metamodel/metamodel.ml

@@ -0,0 +1,458 @@
+open Stdune
+
+type doc =
+  { since : string option
+  ; documentation : string option
+  }
+
+type baseType =
+  | Uri
+  | DocumentUri
+  | Integer
+  | Uinteger
+  | Decimal
+  | RegExp
+  | String
+  | Boolean
+  | Null
+
+type mapKeyType =
+  | Uri
+  | DocumentUri
+  | String
+  | Integer
+  | Reference of string
+
+type literalType =
+  | String of string
+  | Boolean of bool
+  | Integer of int
+  | Record of property list
+
+and property =
+  { doc : doc
+  ; name : string
+  ; optional : bool
+  ; type_ : type_
+  }
+
+and mapType =
+  { key : mapKeyType
+  ; value : type_
+  }
+
+and type_ =
+  | Base of baseType
+  | Reference of string
+  | Array of type_
+  | Or of type_ list
+  | And of type_ list
+  | Tuple of type_ list
+  | Literal of literalType
+  | Map of mapType
+
+type typeAlias =
+  { name : string
+  ; type_ : type_
+  ; doc : doc
+  }
+
+type enumerationEntry =
+  { name : string
+  ; value : [ `String of string | `Int of int ]
+  ; doc : doc
+  }
+
+type enumerationType = { name : [ `String | `Integer | `Uinteger ] }
+
+type enumeration =
+  { doc : doc
+  ; name : string
+  ; supportsCustomValues : bool
+  ; type_ : enumerationType
+  ; values : enumerationEntry list
+  }
+
+type structure =
+  { doc : doc
+  ; extends : type_ list
+  ; mixins : type_ list
+  ; name : string
+  ; properties : property list
+  }
+
+type call =
+  { method_ : string
+  ; params : [ `Param of type_ | `Params of type_ list ] option
+  ; registrationOptions : type_ option
+  ; doc : doc
+  }
+
+type request =
+  { call : call
+  ; errorData : type_ option
+  ; partialResult : type_ option
+  ; result : type_
+  }
+
+type notification = { call : call }
+
+type t =
+  { requests : request list
+  ; notifications : notification list
+  ; structures : structure list
+  ; enumerations : enumeration list
+  ; typeAliases : typeAlias list
+  }
+
+let error msg json = failwith (msg ^ "\n" ^ Yojson.Safe.pretty_to_string ~std:false json)
+
+let fields = function
+  | `Assoc xs -> xs
+  | xs -> error "expected fields" xs
+;;
+
+let field ?default (name : string) p fields =
+  match List.assoc fields name with
+  | Some f -> p f
+  | None ->
+    (match default with
+     | None -> error ("field not found " ^ name) (`Assoc fields)
+     | Some x -> x)
+;;
+
+let field_o name p fields =
+  match List.assoc fields name with
+  | None -> None
+  | Some f -> Some (p f)
+;;
+
+let bool = function
+  | `Bool b -> b
+  | json -> error "boolean expected" json
+;;
+
+let literal lit json = if not (Poly.equal json lit) then error "unexpected literal" json
+
+let enum variants json =
+  match json with
+  | `String s ->
+    (match List.assoc variants s with
+     | None -> error "not a valid enum value" json
+     | Some v -> v)
+  | _ -> error "not a valid enum value" json
+;;
+
+let string = function
+  | `String s -> s
+  | json -> error "expected string" json
+;;
+
+let string_or_number = function
+  | `String s -> `String s
+  | `Int i -> `Int i
+  | json -> error "expected string or number" json
+;;
+
+let name fields = field "name" string fields
+
+let list conv = function
+  | `List xs -> List.map xs ~f:conv
+  | json -> error "expected list" json
+;;
+
+let baseType json : baseType =
+  match json with
+  | `String s ->
+    (match s with
+     | "URI" | "Uri" -> Uri
+     | "DocumentUri" -> DocumentUri
+     | "integer" -> Integer
+     | "uinteger" -> Uinteger
+     | "decimal" -> Decimal
+     | "RegExp" -> RegExp
+     | "string" -> String
+     | "boolean" -> Boolean
+     | "null" -> Null
+     | _ -> error "unknown base type" json)
+  | _ -> error "unknown base type" json
+;;
+
+let mapKeyType json : mapKeyType =
+  let fields = fields json in
+  let kind = field "kind" string fields in
+  match kind with
+  | "reference" -> Reference (name fields)
+  | "base" ->
+    field
+      "name"
+      (enum
+         [ "Uri", Uri
+         ; "URI", Uri
+         ; "DocumentUri", DocumentUri
+         ; "string", String
+         ; "integer", Integer
+         ])
+      fields
+  | kind -> error ("invalid kind for map key type: " ^ kind) json
+;;
+
+let doc fields =
+  let since = field_o "since" string fields in
+  let documentation = field_o "documentation" string fields in
+  { since; documentation }
+;;
+
+let rec type_ json =
+  let fields_conv = fields in
+  let fields = fields json in
+  let kind = field "kind" string fields in
+  match kind with
+  | "reference" -> Reference (name fields)
+  | "array" ->
+    let element = field "element" type_ fields in
+    Array element
+  | "base" ->
+    let b = field "name" baseType fields in
+    Base b
+  | "or" ->
+    let items = field "items" (list type_) fields in
+    Or items
+  | "and" ->
+    let items = field "items" (list type_) fields in
+    And items
+  | "tuple" ->
+    let items = field "items" (list type_) fields in
+    Tuple items
+  | "stringLiteral" ->
+    let value = field "value" string fields in
+    Literal (String value)
+  | "map" ->
+    let key = field "key" mapKeyType fields in
+    let value = field "value" type_ fields in
+    Map { key; value }
+  | "literal" ->
+    let fields =
+      field
+        "value"
+        (fun json ->
+           let fields = fields_conv json in
+           properties fields)
+        fields
+    in
+    Literal (Record fields)
+  | kind -> error "unrecognized kind" (`String kind)
+
+and properties fields : property list = field "properties" (list property) fields
+
+and property json : property =
+  let fields = fields json in
+  let name = name fields in
+  let doc = doc fields in
+  let type_ = type_field fields in
+  let optional = field ~default:false "optional" bool fields in
+  { name; type_; optional; doc }
+
+and type_field fields = field "type" type_ fields
+
+let params = function
+  | `List l -> `Params (List.map l ~f:type_)
+  | `Assoc _ as json -> `Param (type_ json)
+  | json -> error "list or object expected" json
+;;
+
+let call fields =
+  let method_ = field "method" string fields in
+  let params = field_o "params" params fields in
+  let doc = doc fields in
+  let registrationOptions = field_o "registrationOptions" type_ fields in
+  { registrationOptions; doc; method_; params }
+;;
+
+let notification json =
+  let fields = fields json in
+  let call = call fields in
+  { call }
+;;
+
+let request json =
+  let fields = fields json in
+  let call = call fields in
+  let errorData = field_o "errorData" type_ fields in
+  let partialResult = field_o "partialResult" type_ fields in
+  let result = field "result" type_ fields in
+  { call; errorData; partialResult; result }
+;;
+
+let enumerationEntry json : enumerationEntry =
+  let fields = fields json in
+  let name = name fields in
+  let doc = doc fields in
+  let value = field "value" string_or_number fields in
+  { name; value; doc }
+;;
+
+let enumerationType json =
+  let fields = fields json in
+  let () = field "kind" (literal (`String "base")) fields in
+  let name =
+    field
+      "name"
+      (enum [ "integer", `Integer; "string", `String; "uinteger", `Uinteger ])
+      fields
+  in
+  { name }
+;;
+
+let enumeration json =
+  let fields = fields json in
+  let name = name fields in
+  let doc = doc fields in
+  let values = field "values" (list enumerationEntry) fields in
+  let type_ = field "type" enumerationType fields in
+  let supportsCustomValues = field ~default:false "supportsCustomValues" bool fields in
+  { supportsCustomValues; type_; values; name; doc }
+;;
+
+let structure json =
+  let fields = fields json in
+  let doc = doc fields in
+  let name = name fields in
+  let extends = field ~default:[] "extends" (list type_) fields in
+  let mixins = field ~default:[] "mixins" (list type_) fields in
+  let properties = properties fields in
+  { doc; name; extends; mixins; properties }
+;;
+
+let typeAlias json : typeAlias =
+  let fields = fields json in
+  let name = name fields in
+  let type_ = type_field fields in
+  let doc = doc fields in
+  { doc; name; type_ }
+;;
+
+let t json =
+  let fields = fields json in
+  let requests = field "requests" (list request) fields in
+  let notifications = field "notifications" (list notification) fields in
+  let structures = field "structures" (list structure) fields in
+  let enumerations = field "enumerations" (list enumeration) fields in
+  let typeAliases = field "typeAliases" (list typeAlias) fields in
+  { requests; notifications; structures; enumerations; typeAliases }
+;;
+
+type metamodel = t
+
+module Entity = struct
+  type t =
+    | Structure of structure
+    | Enumeration of enumeration
+    | Alias of typeAlias
+
+  module DB = struct
+    type nonrec t = t String.Map.t
+
+    let create
+          ({ structures; requests = _; notifications = _; enumerations; typeAliases } :
+            metamodel)
+      : t
+      =
+      let structures =
+        String.Map.of_list_map_exn structures ~f:(fun s -> s.name, Structure s)
+      in
+      let enumerations =
+        String.Map.of_list_map_exn enumerations ~f:(fun s -> s.name, Enumeration s)
+      in
+      let typeAliases =
+        String.Map.of_list_map_exn typeAliases ~f:(fun a -> a.name, Alias a)
+      in
+      String.Map.union_exn structures enumerations |> String.Map.union_exn typeAliases
+    ;;
+
+    let find t x = String.Map.find_exn t x
+  end
+end
+
+module Path = struct
+  type top =
+    | Request of request
+    | Notification of notification
+    | Structure of structure
+    | Enumeration of enumeration
+    | Alias of typeAlias
+
+  type t =
+    | Top of top
+    | Property of property * t
+end
+
+class map =
+  let open Path in
+  object (self)
+    method property path (p : property) =
+      let path = Property (p, path) in
+      { p with type_ = self#type_ path p.type_ }
+
+    method literal path t =
+      match (t : literalType) with
+      | Record ps -> Record (List.map ps ~f:(self#property path))
+      | _ -> t
+
+    method or_ path types = Or (List.map types ~f:(self#type_ path))
+
+    method type_ path t : type_ =
+      match t with
+      | Base _ as t -> t
+      | Reference _ -> t
+      | Array t -> Array (self#type_ path t)
+      | Or types -> self#or_ path types
+      | And ts -> And (List.map ts ~f:(self#type_ path))
+      | Tuple ts -> Tuple (List.map ts ~f:(self#type_ path))
+      | Literal lt -> Literal (self#literal path lt)
+      | Map mt -> Map { mt with value = self#type_ path mt.value }
+
+    method private call path (c : call) =
+      let params =
+        let params = function
+          | `Param t -> `Param (self#type_ path t)
+          | `Params ts -> `Params (List.map ts ~f:(self#type_ path))
+        in
+        Option.map ~f:params c.params
+      in
+      let registrationOptions = Option.map ~f:(self#type_ path) c.registrationOptions in
+      { c with params; registrationOptions }
+
+    method request (r : request) =
+      let path = Top (Request r) in
+      let call = self#call path r.call in
+      let errorData = Option.map ~f:(self#type_ path) r.errorData in
+      let partialResult = Option.map ~f:(self#type_ path) r.partialResult in
+      let result = self#type_ path r.result in
+      { call; errorData; partialResult; result }
+
+    method notification { call } =
+      let path = Top (Notification { call }) in
+      { call = self#call path call }
+
+    method structure s =
+      let path = Top (Structure s) in
+      let extends = List.map s.extends ~f:(self#type_ path) in
+      let mixins = List.map s.mixins ~f:(self#type_ path) in
+      let properties = List.map s.properties ~f:(self#property path) in
+      { s with extends; mixins; properties }
+
+    method typeAlias (a : typeAlias) =
+      let path = Top (Alias a) in
+      { a with type_ = self#type_ path a.type_ }
+
+    method enumeration (e : enumeration) : enumeration = e
+
+    method t { requests; notifications; structures; enumerations; typeAliases } =
+      let requests = List.map requests ~f:self#request in
+      let notifications = List.map notifications ~f:self#notification in
+      let structures = List.map structures ~f:self#structure in
+      let typeAliases = List.map typeAliases ~f:self#typeAlias in
+      let enumerations = List.map enumerations ~f:self#enumeration in
+      { enumerations; requests; notifications; structures; typeAliases }
+  end

thirdparty/lsp/lsp/bin/metamodel/metamodel.mli

@@ -0,0 +1,149 @@
+type doc =
+  { since : string option
+  ; documentation : string option
+  }
+
+type baseType =
+  | Uri
+  | DocumentUri
+  | Integer
+  | Uinteger
+  | Decimal
+  | RegExp
+  | String
+  | Boolean
+  | Null
+
+type mapKeyType =
+  | Uri
+  | DocumentUri
+  | String
+  | Integer
+  | Reference of string
+
+type literalType =
+  | String of string
+  | Boolean of bool
+  | Integer of int
+  | Record of property list
+
+and property =
+  { doc : doc
+  ; name : string
+  ; optional : bool
+  ; type_ : type_
+  }
+
+and mapType =
+  { key : mapKeyType
+  ; value : type_
+  }
+
+and type_ =
+  | Base of baseType
+  | Reference of string
+  | Array of type_
+  | Or of type_ list
+  | And of type_ list
+  | Tuple of type_ list
+  | Literal of literalType
+  | Map of mapType
+
+type typeAlias =
+  { name : string
+  ; type_ : type_
+  ; doc : doc
+  }
+
+type enumerationEntry =
+  { name : string
+  ; value : [ `Int of int | `String of string ]
+  ; doc : doc
+  }
+
+type enumerationType = { name : [ `Integer | `String | `Uinteger ] }
+
+type enumeration =
+  { doc : doc
+  ; name : string
+  ; supportsCustomValues : bool
+  ; type_ : enumerationType
+  ; values : enumerationEntry list
+  }
+
+type structure =
+  { doc : doc
+  ; extends : type_ list
+  ; mixins : type_ list
+  ; name : string
+  ; properties : property list
+  }
+
+type call =
+  { method_ : string
+  ; params : [ `Param of type_ | `Params of type_ list ] option
+  ; registrationOptions : type_ option
+  ; doc : doc
+  }
+
+type request =
+  { call : call
+  ; errorData : type_ option
+  ; partialResult : type_ option
+  ; result : type_
+  }
+
+type notification = { call : call }
+
+type t =
+  { requests : request list
+  ; notifications : notification list
+  ; structures : structure list
+  ; enumerations : enumeration list
+  ; typeAliases : typeAlias list
+  }
+
+val t : Yojson.Safe.t -> t
+
+module Entity : sig
+  type metamodel := t
+
+  type t =
+    | Structure of structure
+    | Enumeration of enumeration
+    | Alias of typeAlias
+
+  module DB : sig
+    type entity := t
+    type t
+
+    val create : metamodel -> t
+    val find : t -> string -> entity
+  end
+end
+
+module Path : sig
+  type top =
+    | Request of request
+    | Notification of notification
+    | Structure of structure
+    | Enumeration of enumeration
+    | Alias of typeAlias
+
+  type t =
+    | Top of top
+    | Property of property * t
+end
+
+class map : object
+  method literal : Path.t -> literalType -> literalType
+  method property : Path.t -> property -> property
+  method or_ : Path.t -> type_ list -> type_
+  method type_ : Path.t -> type_ -> type_
+  method t : t -> t
+  method request : request -> request
+  method structure : structure -> structure
+  method notification : notification -> notification
+  method typeAlias : typeAlias -> typeAlias
+  method enumeration : enumeration -> enumeration
+end

thirdparty/lsp/lsp/bin/named.ml

@@ -0,0 +1,15 @@
+type 'a t =
+  { name : string
+  ; data : 'a
+  }
+
+let make ~name data = { name; data }
+let data t = t.data
+let name t = t.name
+let map t ~f = { t with data = f t.data }
+let set_data t data = { t with data }
+
+let to_dyn f { name; data } =
+  let open Dyn in
+  record [ "name", String name; "data", f data ]
+;;

thirdparty/lsp/lsp/bin/ocaml/json_gen.ml

@@ -0,0 +1,273 @@
+open! Import
+open Ml
+
+let json_t = Type.Path (Dot (Ident "Json", "t"))
+
+let pat_of_literal (t : Ts_types.Literal.t) : Expr.pat =
+  let open Expr in
+  let tag, args =
+    match t with
+    | Ts_types.Literal.String s -> "String", Pat (Expr.String s)
+    | Int i -> "Int", Pat (Expr.Int i)
+    | Float _ -> assert false
+  in
+  Pat (Constr { poly = true; tag; args = [ args ] })
+;;
+
+let constr_of_literal (t : Ts_types.Literal.t) : Expr.t =
+  let open Expr in
+  let tag, args =
+    match t with
+    | Ts_types.Literal.String s -> "String", Create (Expr.String s)
+    | Int i -> "Int", Create (Expr.Int i)
+    | Float _ -> assert false
+  in
+  Create (Constr { poly = true; tag; args = [ args ] })
+;;
+
+let json_error_pat msg =
+  let open Expr in
+  ( Wildcard
+  , App
+      ( Create (Ident "Json.error")
+      , [ Unnamed (Create (String msg)); Unnamed (Create (Ident "json")) ] ) )
+;;
+
+let is_json_constr (constr : Type.constr) =
+  List.mem [ "String"; "Int"; "Bool" ] constr.name ~equal:String.equal
+;;
+
+module Name = struct
+  let of_ = sprintf "%s_of_yojson"
+  let to_ = sprintf "yojson_of_%s"
+
+  let conv = function
+    | `To -> to_
+    | `Of -> of_
+  ;;
+end
+
+open Arg
+
+let of_json ~name expr =
+  let pat = [ Unnamed "json", Type.json ] in
+  let data = { Expr.pat; type_ = Type.name name; body = expr } in
+  let name = Name.of_ name in
+  { Named.name; data }
+;;
+
+let to_json ~name expr =
+  let pat = [ Unnamed name, Type.name name ] in
+  let data = { Expr.pat; type_ = Type.json; body = expr } in
+  let name = Name.to_ name in
+  { Named.name; data }
+;;
+
+let add_json_conv_for_t (sig_ : Module.sig_ Module.t) =
+  let conv_t =
+    { Named.name = "t"
+    ; data =
+        (let t = Type.Path (Path.Ident "t") in
+         Module.Include (Module.Name.of_string "Json.Jsonable.S", [ t, t ]))
+    }
+  in
+  { sig_ with bindings = sig_.bindings @ [ conv_t ] }
+;;
+
+module Enum = struct
+  let of_json ~allow_other ~poly { Named.name; data = constrs } =
+    let open Ml.Expr in
+    let body =
+      let clauses =
+        List.map constrs ~f:(fun (constr, literal) ->
+          let pat = pat_of_literal literal in
+          let tag = constr in
+          pat, Create (Constr { tag; poly; args = [] }))
+      in
+      let clauses =
+        if allow_other
+        then (
+          let s = Ident "s" in
+          let pat = Pat (Constr { tag = "String"; poly = true; args = [ Pat s ] }) in
+          let make = Create (Constr { tag = "Other"; poly; args = [ Create s ] }) in
+          clauses @ [ pat, make ])
+        else clauses
+      in
+      let msg =
+        sprintf
+          "Invalid value. Expected one of: %s"
+          (List.map constrs ~f:(fun (_, literal) ->
+             Ts_types.Literal.to_maybe_quoted_string literal)
+           |> String.concat ~sep:", ")
+      in
+      Match (Create (Ident "json"), clauses @ [ json_error_pat msg ])
+    in
+    of_json ~name body
+  ;;
+
+  let to_json ~allow_other ~poly { Named.name; data = constrs } =
+    let open Ml.Expr in
+    let body =
+      let clauses =
+        List.map constrs ~f:(fun (constr, literal) ->
+          let pat = Pat (Constr { tag = constr; poly; args = [] }) in
+          pat, constr_of_literal literal)
+      in
+      let clauses =
+        if allow_other
+        then (
+          let s = Ident "s" in
+          let pat = Pat (Constr { tag = "Other"; poly; args = [ Pat s ] }) in
+          let make =
+            Create (Constr { tag = "String"; poly = true; args = [ Create s ] })
+          in
+          clauses @ [ pat, make ])
+        else clauses
+      in
+      Match (Create (Ident name), clauses)
+    in
+    to_json ~name body
+  ;;
+
+  let conv ~allow_other ~poly t =
+    let to_json = to_json ~allow_other ~poly t in
+    let of_json = of_json ~allow_other ~poly t in
+    [ to_json; of_json ]
+  ;;
+end
+
+module Poly_variant = struct
+  type constrs =
+    { json_constrs : Ml.Type.constr list
+    ; untagged_constrs : Ml.Type.constr list
+    }
+
+  let split_clauses constrs =
+    let json_constrs, untagged_constrs =
+      List.partition_map constrs ~f:(fun x ->
+        if is_json_constr x then Left x else Right x)
+    in
+    { json_constrs; untagged_constrs }
+  ;;
+
+  let conv_of_constr target (utc : Ml.Type.constr) =
+    let rec conv (p : Ml.Path.t) : Ml.Path.t =
+      match p with
+      | Ident name -> Ident (Name.conv target name)
+      | Dot (s, name) -> Dot (s, Name.conv target name)
+      | Apply (s, y) -> Apply (s, conv y)
+    in
+    let conv p = Ml.Path.to_string (conv p) in
+    let open Ml.Expr in
+    let json_mod n =
+      match target with
+      | `To -> Ident ("Json.To." ^ n)
+      | `Of -> Ident ("Json.Of." ^ n)
+    in
+    let conv t = Create (Ident (conv t)) in
+    match (utc.args : Ml.Type.t list) with
+    | [ Path p ] -> conv p
+    | [ List (Prim p) ] ->
+      let ident =
+        match p with
+        | String -> "string"
+        | _ -> assert false
+      in
+      App (Create (json_mod "list"), [ Unnamed (conv (Ident ident)) ])
+    | [ List (Path p) ] -> App (Create (json_mod "list"), [ Unnamed (conv p) ])
+    | [ Tuple [ Prim Int; Prim Int ] ] -> Create (json_mod "int_pair")
+    | [] -> assert false
+    | _ -> Code_error.raise "untagged" [ "utc", Ml.Type.dyn_of_constr utc ]
+  ;;
+
+  let json_clauses json_constrs =
+    List.map json_constrs ~f:(fun (c : Ml.Type.constr) ->
+      let open Ml.Expr in
+      let constr arg = Constr { tag = c.name; poly = true; args = [ arg ] } in
+      let pat = Pat (constr (Pat (Ident "j"))) in
+      let expr : t = Create (constr (Create (Ident "j"))) in
+      pat, expr)
+  ;;
+
+  let to_json { Named.name; data = constrs } =
+    let { json_constrs; untagged_constrs } = split_clauses constrs in
+    let open Ml.Expr in
+    let json_clauses = json_clauses json_constrs in
+    let untagged_clauses =
+      List.map untagged_constrs ~f:(fun (utc : Ml.Type.constr) ->
+        let constr arg = Constr { tag = utc.name; poly = true; args = [ arg ] } in
+        let pat = Pat (constr (Pat (Ident "s"))) in
+        let expr = App (conv_of_constr `To utc, [ Unnamed (Create (Ident "s")) ]) in
+        pat, expr)
+    in
+    let expr = Match (Create (Ident name), json_clauses @ untagged_clauses) in
+    to_json ~name expr
+  ;;
+
+  let of_json { Named.name; data = constrs } =
+    let { json_constrs; untagged_constrs } = split_clauses constrs in
+    let open Ml.Expr in
+    let clauses = json_clauses json_constrs in
+    let untagged =
+      let args =
+        let constrs =
+          List.map untagged_constrs ~f:(fun (utc : Ml.Type.constr) ->
+            let create =
+              let of_json =
+                App (conv_of_constr `Of utc, [ Unnamed (Create (Ident "json")) ])
+              in
+              Create (Constr { tag = utc.name; poly = true; args = [ of_json ] })
+            in
+            Fun ([ Unnamed (Pat (Ident "json")) ], create))
+        in
+        Create (List constrs)
+      in
+      App
+        ( Create (Ident "Json.Of.untagged_union")
+        , [ Unnamed (Create (String name))
+          ; Unnamed args
+          ; Unnamed (Create (Ident "json"))
+          ] )
+    in
+    let expr =
+      match json_constrs, untagged_constrs with
+      | [], [] -> assert false
+      | [], _ -> untagged
+      | _, [] -> Match (Create (Ident "json"), clauses @ [ json_error_pat name ])
+      | _ :: _, _ :: _ -> Match (Create (Ident "json"), clauses @ [ Wildcard, untagged ])
+    in
+    of_json ~name expr
+  ;;
+end
+
+(* [name] is used as the pattern in the "to" converter. In the "of" converter,
+   it's used to generate better error messages. *)
+let make_literal_wrapper_conv ~field_name ~literal_value ~type_name =
+  (* Some json representations require an extra "kind" field set to some string
+     constant *)
+  let open Ml.Expr in
+  let args = List.map ~f:(fun x -> Ml.Arg.Unnamed (Create x)) in
+  let to_ =
+    let a =
+      [ String field_name
+      ; String literal_value
+      ; Ident (Name.conv `To type_name)
+      ; Ident type_name
+      ]
+    in
+    App (Create (Ident "Json.To.literal_field"), args a)
+  in
+  let of_ =
+    let a =
+      [ String type_name
+      ; String field_name
+      ; String literal_value
+      ; Ident (Name.conv `Of type_name)
+      ; Ident "json"
+      ]
+    in
+    App (Create (Ident "Json.Of.literal_field"), args a)
+  in
+  [ to_json ~name:type_name to_; of_json ~name:type_name of_ ]
+  |> List.map ~f:(Named.map ~f:(fun v -> Ml.Module.Value v))
+;;

thirdparty/lsp/lsp/bin/ocaml/json_gen.mli

@@ -0,0 +1,21 @@
+val json_t : Ml.Type.t
+val add_json_conv_for_t : Ml.Module.sig_ Ml.Module.t -> Ml.Module.sig_ Ml.Module.t
+
+module Enum : sig
+  val conv
+    :  allow_other:bool
+    -> poly:bool
+    -> (string * Ts_types.Literal.t) list Named.t
+    -> Ml.Expr.toplevel Named.t list
+end
+
+module Poly_variant : sig
+  val of_json : Ml.Type.constr list Named.t -> Ml.Expr.toplevel Named.t
+  val to_json : Ml.Type.constr list Named.t -> Ml.Expr.toplevel Named.t
+end
+
+val make_literal_wrapper_conv
+  :  field_name:string
+  -> literal_value:string
+  -> type_name:string
+  -> Ml.Module.impl Named.t list

thirdparty/lsp/lsp/bin/ocaml/ml.ml

@@ -0,0 +1,598 @@
+open Import
+
+module Kind = struct
+  type t =
+    | Intf
+    | Impl
+
+  type ('intf, 'impl) pair =
+    { intf : 'intf
+    ; impl : 'impl
+    }
+
+  module Map = struct
+    type 'a t = ('a, 'a) pair
+
+    let get { intf; impl } = function
+      | Impl -> impl
+      | Intf -> intf
+    ;;
+
+    let make_both a = { intf = a; impl = a }
+
+    let iter { intf; impl } ~f =
+      f intf;
+      f impl
+    ;;
+
+    let map { intf; impl } ~f = { intf = f intf; impl = f impl }
+
+    let both (type a b) (x : a t) (y : b t) : (a * b) t =
+      { intf = x.intf, y.intf; impl = x.impl, y.impl }
+    ;;
+  end
+end
+
+let is_kw = function
+  | "type" | "method" | "end" | "to" | "external" -> true
+  | _ -> false
+;;
+
+module Arg = struct
+  type 'e t =
+    | Unnamed of 'e
+    | Labeled of string * 'e
+    | Optional of string * 'e
+
+  let to_dyn f =
+    let open Dyn in
+    function
+    | Unnamed a -> Dyn.variant "Unnamed" [ f a ]
+    | Labeled (s, a) -> Dyn.variant "Labeled" [ string s; f a ]
+    | Optional (s, a) -> Dyn.variant "Optional" [ string s; f a ]
+  ;;
+end
+
+module Path = struct
+  type t =
+    | Ident of string
+    | Dot of t * string
+    | Apply of t * t
+
+  let rec to_string = function
+    | Ident s -> s
+    | Dot (t, s) -> to_string t ^ "." ^ s
+    | Apply (f, x) -> to_string f ^ "(" ^ to_string x ^ ")"
+  ;;
+
+  let rec pp = function
+    | Ident s -> Pp.verbatim s
+    | Dot (s, p) -> Pp.concat [ pp s; Pp.verbatim "."; Pp.verbatim p ]
+    | Apply (s, p) -> Pp.concat [ pp s; W.surround `Paren (pp p) ]
+  ;;
+end
+
+module Type = struct
+  [@@@warning "-30"]
+
+  type prim =
+    | Unit
+    | String
+    | Int
+    | Bool
+
+  let dyn_of_prim : prim -> Dyn.t =
+    let open Dyn in
+    function
+    | Unit -> variant "Unit" []
+    | String -> variant "String" []
+    | Int -> variant "Int" []
+    | Bool -> variant "Bool" []
+  ;;
+
+  type t =
+    | Path of Path.t
+    | Var of string
+    | Prim of prim
+    | Tuple of t list
+    | Optional of t
+    | List of t
+    | Poly_variant of constr list
+    | Assoc of t * t
+    | App of t * t list
+    | Fun of t Arg.t * t
+
+  and constr =
+    { name : string
+    ; args : t list
+    }
+
+  and field =
+    { name : string
+    ; typ : t
+    ; attrs : (string * string list) list
+    }
+
+  let rec to_dyn =
+    let open Dyn in
+    function
+    | Var v -> variant "Var" [ string v ]
+    | List v -> variant "List" [ to_dyn v ]
+    | Assoc (x, y) -> variant "Assoc" [ to_dyn x; to_dyn y ]
+    | Tuple xs -> variant "Tuple" (List.map ~f:to_dyn xs)
+    | Optional t -> variant "Optional" [ to_dyn t ]
+    | Path p -> variant "Path" [ string @@ Path.to_string p ]
+    | Poly_variant xs -> variant "Poly_variant" (List.map ~f:dyn_of_constr xs)
+    | App (x, y) -> variant "App" (to_dyn x :: List.map y ~f:to_dyn)
+    | Prim p -> variant "Prim" [ dyn_of_prim p ]
+    | Fun (arg, t) -> variant "Fun" [ Arg.to_dyn to_dyn arg; to_dyn t ]
+
+  and dyn_of_constr { name; args } =
+    Dyn.(record [ "name", string name; "args", (list to_dyn) args ])
+
+  and dyn_of_field { name; typ; attrs } =
+    let open Dyn in
+    record
+      [ "name", string name
+      ; "typ", to_dyn typ
+      ; "attrs", list (pair string (list string)) attrs
+      ]
+  ;;
+
+  type decl =
+    | Alias of t
+    | Record of field list
+    | Variant of constr list
+
+  let dyn_of_decl =
+    let open Dyn in
+    function
+    | Alias a -> variant "Alias" [ to_dyn a ]
+    | Record fs -> variant "Record" (List.map ~f:dyn_of_field fs)
+    | Variant cs -> variant "Variant" (List.map ~f:dyn_of_constr cs)
+  ;;
+
+  class virtual ['env, 'm] mapreduce =
+    object (self : 'self)
+      method virtual empty : 'm
+      method virtual plus : 'm -> 'm -> 'm
+
+      method poly_variant env constrs =
+        let r, s = self#fold_left_map constrs ~f:(fun c -> self#constr env c) in
+        Poly_variant r, s
+
+      method tuple (env : 'env) t =
+        let (r : t list), s = self#fold_left_map t ~f:(fun (t : t) -> self#t env t) in
+        Tuple r, s
+
+      method path _ p = Path p, self#empty
+      method var _ n = Var n, self#empty
+      method prim _ p = Prim p, self#empty
+
+      method optional env p =
+        let t, s = self#t env p in
+        Optional t, s
+
+      method list env t =
+        let t, s = self#t env t in
+        List t, s
+
+      method assoc env k v =
+        let k, s1 = self#t env k in
+        let v, s2 = self#t env v in
+        Assoc (k, v), self#plus s1 s2
+
+      method app env f xs =
+        let f, s1 = self#t env f in
+        let xs, s2 = self#fold_left_map xs ~f:(fun x -> self#t env x) in
+        App (f, xs), self#plus s1 s2
+
+      method t env this =
+        match (this : t) with
+        | Path p -> self#path env p
+        | Var v -> self#var env v
+        | Prim p -> self#prim env p
+        | Tuple t -> self#tuple env t
+        | Optional t -> self#optional env t
+        | List t -> self#list env t
+        | Poly_variant t -> self#poly_variant env t
+        | Assoc (k, v) -> self#assoc env k v
+        | App (f, xs) -> self#app env f xs
+        | Fun (_, _) -> assert false
+
+      method alias env t =
+        let r0, s0 = self#t env t in
+        Alias r0, s0
+
+      method constr env (constr : constr) =
+        let args, s = self#fold_left_map constr.args ~f:(fun t -> self#t env t) in
+        { constr with args }, s
+
+      method private fold_left_map : 'a. f:('a -> 'a * 'm) -> 'a list -> 'a list * 'm =
+        fun ~f xs ->
+          let accf, accm =
+            List.fold_left xs ~init:([], self#empty) ~f:(fun (accf, accm) x ->
+              let r, s = f x in
+              r :: accf, self#plus accm s)
+          in
+          List.rev accf, accm
+
+      method field env f =
+        let typ, s = self#t env f.typ in
+        { f with typ }, s
+
+      method record env fields =
+        let r, s = self#fold_left_map fields ~f:(fun f -> self#field env f) in
+        Record r, s
+
+      method variant env constrs =
+        let v, s = self#fold_left_map constrs ~f:(fun f -> self#constr env f) in
+        Variant v, s
+
+      method decl env decl =
+        match decl with
+        | Alias a -> self#alias env a
+        | Record fs -> self#record env fs
+        | Variant v -> self#variant env v
+    end
+
+  let field typ ~name = { name; typ; attrs = [] }
+  let fun_ args t = List.fold_right args ~init:t ~f:(fun arg acc -> Fun (arg, acc))
+  let constr args ~name = { name; args }
+  let list t = List t
+  let assoc_list ~key ~data = Assoc (key, data)
+  let t = Path (Ident "t")
+  let module_t m = Path (Dot (Ident (String.capitalize_ascii m), "t"))
+  let string = Prim String
+  let name s = Path (Ident s)
+  let int = Prim Int
+  let bool = Prim Bool
+  let alpha = Var "a"
+
+  let enum constrs =
+    Variant (List.map constrs ~f:(fun constr -> { name = constr; args = [] }))
+  ;;
+
+  let poly_enum constrs =
+    Poly_variant (List.map constrs ~f:(fun constr -> { name = constr; args = [] }))
+  ;;
+
+  let json = Path (Dot (Ident "Json", "t"))
+  let unit = Prim Unit
+  let array t = App (Path (Ident "array"), [ t ])
+
+  let void =
+    let void = Path.Dot (Ident "Json", "Void") in
+    Path (Dot (void, "t"))
+  ;;
+
+  let json_object =
+    let obj = Path.Dot (Ident "Json", "Object") in
+    Path (Dot (obj, "t"))
+  ;;
+
+  module Type = W.Type
+
+  let pp_prim (p : prim) : W.t =
+    match p with
+    | String -> Pp.verbatim "string"
+    | Int -> Pp.verbatim "int"
+    | Bool -> Pp.verbatim "bool"
+    | Unit -> Pp.verbatim "unit"
+  ;;
+
+  let rec pp (a : t) ~(kind : Kind.t) : W.t =
+    match a with
+    | Prim p -> pp_prim p
+    | Var v -> Type.var v
+    | Path p -> Path.pp p
+    | App (f, xs) -> Type.app (pp ~kind f) (List.map ~f:(pp ~kind) xs)
+    | Tuple t -> Type.tuple (List.map ~f:(pp ~kind) t)
+    | Optional t -> pp ~kind (App (Path (Ident "option"), [ t ]))
+    | List t -> pp ~kind (App (Path (Ident "list"), [ t ]))
+    | Poly_variant constrs ->
+      List.map constrs ~f:(fun { name; args } -> name, List.map args ~f:(pp ~kind))
+      |> Type.poly
+    | Assoc (k, v) ->
+      let t = List (Tuple [ k; v ]) in
+      pp t ~kind
+    | Fun (a, r) ->
+      (match a with
+       | Arg.Unnamed t ->
+         Pp.concat [ pp t ~kind; Pp.space; Pp.verbatim "->"; Pp.space; pp ~kind r ]
+       | Arg.Labeled (l, t) ->
+         Pp.concat
+           [ Pp.textf "%s:" l
+           ; pp t ~kind
+           ; Pp.space
+           ; Pp.verbatim "->"
+           ; Pp.space
+           ; pp ~kind r
+           ]
+       | Arg.Optional (l, t) ->
+         Pp.concat
+           [ Pp.textf "?%s:" l
+           ; pp t ~kind
+           ; Pp.space
+           ; Pp.verbatim "->"
+           ; Pp.space
+           ; pp ~kind r
+           ])
+  ;;
+
+  let pp_decl' ~(kind : Kind.t) (a : decl) =
+    match a with
+    | Alias a ->
+      let pp = pp ~kind a in
+      (match a, kind with
+       | (List _ | Path _ | Prim _), Impl -> W.Type.deriving ~record:false pp
+       | _, _ -> pp)
+    | Variant v ->
+      List.map v ~f:(fun { name; args } -> name, List.map ~f:(pp ~kind) args)
+      |> Type.variant
+    | Record r ->
+      let r =
+        List.map r ~f:(fun { name; typ; attrs } ->
+          let def =
+            let field = pp ~kind typ in
+            let attrs =
+              let attrs =
+                match kind with
+                | Intf -> []
+                | Impl -> attrs
+              in
+              List.concat_map attrs ~f:(fun (a, r) ->
+                [ W.Attr.make a (List.map ~f:Pp.verbatim r) ])
+            in
+            Type.field_attrs ~field ~attrs
+          in
+          name, def)
+        |> Type.record
+      in
+      (match kind with
+       | Intf -> r
+       | Impl -> W.Type.deriving r ~record:true)
+  ;;
+
+  let pp_decl ~name ~kind (a : decl) : W.t =
+    let body = pp_decl' ~kind a in
+    Type.decl name body
+  ;;
+end
+
+module Expr = struct
+  [@@@ocaml.warning "-30-32-37"]
+
+  type expr =
+    | Let of pat * expr * expr (** let pat = e1 in e2 *)
+    | Match of expr * (pat * expr) list (** match e1 with [p -> e]* *)
+    | Fun of pat Arg.t list * expr (** fun p2 p2 .. -> e *)
+    | App of expr * expr Arg.t list (** f e1 e2 .. *)
+    | Create of expr prim (** Literal/Primitive *)
+    | Assert_false (** assert false *)
+
+  and 'e prim =
+    | Unit
+    | Bool of bool
+    | Int of int
+    | String of string
+    | Ident of string
+    | Cons of 'e * 'e prim
+    | List of 'e list
+    | Tuple of 'e list
+    | Record of 'e record_
+    | Constr of 'e constr
+
+  and pat =
+    | Wildcard
+    | Pat of pat prim
+
+  and 'e record_ = (string * 'e) list
+
+  and 'e constr =
+    { tag : string
+    ; poly : bool
+    ; args : 'e list
+    }
+
+  type t = expr
+
+  let assert_false_clause = Wildcard, Assert_false
+
+  type toplevel =
+    { pat : (string Arg.t * Type.t) list
+    ; type_ : Type.t
+    ; body : t
+    }
+
+  let constr ?(poly = false) ?(args = []) tag = { poly; args; tag }
+
+  let pp_constr f { tag; poly; args } =
+    let tag =
+      let tag = String.capitalize tag in
+      Pp.verbatim (if poly then "`" ^ tag else tag)
+    in
+    match args with
+    | [] -> tag
+    | args ->
+      let sep = Pp.verbatim "," in
+      let args = W.surround `Paren (Pp.concat_map ~sep ~f args) in
+      Pp.concat [ tag; Pp.space; args ]
+  ;;
+
+  let rec pp_pat = function
+    | Wildcard -> Pp.verbatim "_"
+    | Pat pat ->
+      (match pat with
+       | Unit -> Pp.verbatim "()"
+       | Bool b -> Pp.textf "%b" b
+       | Int i -> Pp.textf "%i" i
+       | String s -> Pp.textf "%S" s
+       | Ident s -> Pp.verbatim s
+       | Cons _ -> assert false
+       | List _ -> assert false
+       | Tuple _ -> assert false
+       | Record _ -> assert false
+       | Constr c -> pp_constr pp_pat c)
+  ;;
+
+  let rec pp_create : expr prim -> _ Pp.t = function
+    | Unit -> Pp.verbatim "()"
+    | Bool b -> Pp.textf "%b" b
+    | Int i ->
+      let pp = Pp.textf "%i" i in
+      if i < 0 then W.surround `Paren pp else pp
+    | String s -> Pp.textf "%S" s
+    | Ident s -> Pp.verbatim s
+    | Cons _ -> assert false
+    | List xs ->
+      let xs = Pp.concat_map xs ~sep:(Pp.verbatim ";") ~f:pp in
+      W.surround `Square xs
+    | Tuple _ -> assert false
+    | Record fields ->
+      let record =
+        let open Pp.O in
+        Pp.concat_map
+          fields
+          ~sep:(Pp.verbatim ";" ++ Pp.space)
+          ~f:(fun (name, expr) ->
+            if expr = Create (Ident name)
+            then pp expr
+            else Pp.verbatim name ++ Pp.space ++ Pp.verbatim "=" ++ pp expr)
+      in
+      W.surround `Curly record
+    | Constr c -> pp_constr pp c
+
+  and pp = function
+    | Assert_false -> Pp.verbatim "assert false"
+    | Match (expr, patterns) ->
+      let with_ =
+        Pp.concat [ Pp.verbatim "match"; Pp.space; pp expr; Pp.space; Pp.verbatim "with" ]
+      in
+      let clauses =
+        Pp.concat_map patterns ~f:(fun (pat, expr) ->
+          Pp.concat
+            [ Pp.verbatim "| "
+            ; pp_pat pat
+            ; Pp.space
+            ; Pp.verbatim "->"
+            ; Pp.space
+            ; Pp.verbatim "("
+            ; pp expr
+            ; Pp.verbatim ")"
+            ])
+      in
+      Pp.concat [ with_; Pp.newline; clauses ]
+    | Create c -> pp_create c
+    | App (x, args) ->
+      let args =
+        Pp.concat_map args ~sep:Pp.space ~f:(fun arg ->
+          match arg with
+          | Unnamed e -> pp e
+          | _ -> assert false)
+      in
+      Pp.concat [ pp x; Pp.space; args ]
+    | Fun (pats, expr) ->
+      W.surround
+        `Paren
+        (Pp.concat
+           [ Pp.verbatim "fun"
+           ; Pp.space
+           ; Pp.concat_map pats ~sep:Pp.space ~f:(fun arg ->
+               match arg with
+               | Unnamed e -> pp_pat e
+               | _ -> assert false)
+           ; Pp.space
+           ; Pp.verbatim "->"
+           ; pp expr
+           ])
+    | _ -> assert false
+  ;;
+
+  let pp_toplevel ~kind name { pat; type_; body } =
+    let pat =
+      Pp.concat_map pat ~f:(fun (pat, typ) ->
+        let typ = Type.pp ~kind typ in
+        match pat with
+        | Unnamed s ->
+          Pp.concat
+            [ Pp.verbatim "("; Pp.verbatim s; Pp.verbatim " : "; typ; Pp.verbatim ")" ]
+        | Labeled (l, r) ->
+          if l = r
+          then Pp.concat [ Pp.textf "~(%s :" l; typ; Pp.verbatim ")" ]
+          else assert false
+        | Optional (l, r) ->
+          if l = r
+          then Pp.concat [ Pp.textf "?(%s :" l; typ; Pp.space; Pp.verbatim "option)" ]
+          else assert false)
+    in
+    let body = pp body in
+    let type_ = Type.pp type_ ~kind in
+    Pp.concat
+      [ Pp.textf "let %s" name
+      ; pat
+      ; Pp.textf " : "
+      ; type_
+      ; Pp.textf "="
+      ; Pp.newline
+      ; body
+      ]
+  ;;
+end
+
+module Module = struct
+  module Name : sig
+    type t = private string
+
+    val of_string : string -> t
+  end = struct
+    type t = string
+
+    let of_string s =
+      match s.[0] with
+      | 'a' .. 'z' -> Code_error.raise "invalid module name" [ "s", Dyn.string s ]
+      | _ -> s
+    ;;
+  end
+
+  type 'a t =
+    { name : Name.t
+    ; bindings : 'a Named.t list
+    }
+
+  let empty name = { name; bindings = [] }
+
+  type sig_ =
+    | Value of Type.t
+    | Type_decl of Type.decl
+    | Include of Name.t * (Type.t * Type.t) list
+
+  type impl =
+    | Type_decl of Type.decl
+    | Value of Expr.toplevel
+
+  let pp_sig { name; bindings } =
+    let bindings =
+      Pp.concat_map bindings ~sep:Pp.newline ~f:(fun { name; data } ->
+        match (data : sig_) with
+        | Value t -> W.Sig.val_ name [ Type.pp ~kind:Intf t ]
+        | Type_decl t -> W.Type.decl name (Type.pp_decl' ~kind:Intf t)
+        | Include (mod_, destructive_subs) ->
+          List.map destructive_subs ~f:(fun (l, r) ->
+            let f = Type.pp ~kind:Intf in
+            f l, f r)
+          |> W.Sig.include_ (mod_ :> string))
+    in
+    W.Sig.module_ (name :> string) bindings
+  ;;
+
+  let pp_impl { name; bindings } =
+    let bindings =
+      Pp.concat_map bindings ~sep:Pp.newline ~f:(fun { name; data = v } ->
+        match v with
+        | Value decl -> Expr.pp_toplevel ~kind:Impl name decl
+        | Type_decl t -> W.Type.decl name (Type.pp_decl' ~kind:Impl t))
+    in
+    W.module_ (name :> string) bindings
+  ;;
+end

thirdparty/lsp/lsp/bin/ocaml/ml.mli

@@ -0,0 +1,227 @@
+(** Representation of OCaml code used for generation *)
+
+val is_kw : string -> bool
+
+module Kind : sig
+  type t =
+    | Intf
+    | Impl
+
+  type ('intf, 'impl) pair =
+    { intf : 'intf
+    ; impl : 'impl
+    }
+
+  module Map : sig
+      type 'a t = ('a, 'a) pair
+      type kind
+
+      val get : 'a t -> kind -> 'a
+      val iter : 'a t -> f:('a -> unit) -> unit
+      val map : 'a t -> f:('a -> 'b) -> 'b t
+      val both : 'a t -> 'b t -> ('a * 'b) t
+      val make_both : 'a -> 'a t
+    end
+    with type kind := t
+end
+
+module Arg : sig
+  (** Represent arrow types and argument patterns *)
+
+  type 'e t =
+    | Unnamed of 'e
+    | Labeled of string * 'e
+    | Optional of string * 'e
+end
+
+module Path : sig
+  type t =
+    | Ident of string
+    | Dot of t * string
+    | Apply of t * t
+
+  val to_string : t -> string
+end
+
+module Type : sig
+  [@@@warning "-30"]
+
+  type prim =
+    | Unit
+    | String
+    | Int
+    | Bool
+
+  type t =
+    | Path of Path.t
+    | Var of string
+    | Prim of prim
+    | Tuple of t list
+    | Optional of t
+    | List of t
+    | Poly_variant of constr list
+    | Assoc of t * t
+    | App of t * t list
+    | Fun of t Arg.t * t
+
+  and field =
+    { name : string
+    ; typ : t
+    ; attrs : (string * string list) list
+    }
+
+  and constr =
+    { name : string
+    ; args : t list
+    }
+
+  val to_dyn : t -> Dyn.t
+  val dyn_of_constr : constr -> Dyn.t
+
+  type decl =
+    | Alias of t
+    | Record of field list
+    | Variant of constr list
+
+  val dyn_of_decl : decl -> Dyn.t
+  val fun_ : t Arg.t list -> t -> t
+
+  (* This is for lists where the keys are equal to strings *)
+  val assoc_list : key:t -> data:t -> t
+  val pp_decl : name:string -> kind:Kind.t -> decl -> unit Pp.t
+  val pp : t -> kind:Kind.t -> unit Pp.t
+  val field : t -> name:string -> field
+  val constr : t list -> name:string -> constr
+
+  (** Simplified sum types*)
+  val enum : string list -> decl
+
+  (** Polymorphic variant form *)
+  val poly_enum : string list -> t
+
+  val list : t -> t
+  val module_t : string -> t
+  val t : t
+  val string : t
+  val name : string -> t
+  val int : t
+  val bool : t
+  val alpha : t
+  val json : t
+  val json_object : t
+  val unit : t
+  val void : t
+  val array : t -> t
+
+  (** Fold and map over a type expression.
+
+      ['m] is the type of monoid summarized.
+
+      ['env] is a custom value threaded through the path. Parent nodes can use
+      this to give child nodes context *)
+  class virtual ['env, 'm] mapreduce : object ('self)
+    method virtual empty : 'm
+    method virtual plus : 'm -> 'm -> 'm
+
+    (** doesn't really to be here, but putting it here avoids passing [empty]
+        and [plus] to a general purpose [fold_left_map]*)
+    method private fold_left_map : 'a. f:('a -> 'a * 'm) -> 'a list -> 'a list * 'm
+
+    method alias : 'env -> t -> decl * 'm
+    method app : 'env -> t -> t list -> t * 'm
+    method assoc : 'env -> t -> t -> t * 'm
+    method constr : 'env -> constr -> constr * 'm
+    method field : 'env -> field -> field * 'm
+    method list : 'env -> t -> t * 'm
+    method path : 'env -> Path.t -> t * 'm
+    method optional : 'env -> t -> t * 'm
+    method poly_variant : 'env -> constr list -> t * 'm
+    method prim : 'env -> prim -> t * 'm
+    method record : 'env -> field list -> decl * 'm
+    method t : 'env -> t -> t * 'm
+    method decl : 'env -> decl -> decl * 'm
+    method tuple : 'env -> t list -> t * 'm
+    method var : 'env -> string -> t * 'm
+    method variant : 'env -> constr list -> decl * 'm
+  end
+end
+
+module Expr : sig
+  (** An (untyped) ocaml expression. It is the responsibility of the generator
+      to create well typed expressions *)
+  type expr =
+    | Let of pat * expr * expr
+    | Match of expr * (pat * expr) list
+    | Fun of pat Arg.t list * expr
+    | App of expr * expr Arg.t list
+    | Create of expr prim
+    | Assert_false
+
+  (* patterns or constructors, depending on ['e] *)
+  and 'e prim =
+    | Unit
+    | Bool of bool
+    | Int of int
+    | String of string
+    (* This should be Path.t as well *)
+    | Ident of string
+    | Cons of 'e * 'e prim
+    | List of 'e list
+    | Tuple of 'e list
+    | Record of 'e record_
+    | Constr of 'e constr
+
+  and pat =
+    | Wildcard (** [_ -> ] *)
+    | Pat of pat prim
+
+  and 'e record_ = (string * 'e) list
+
+  and 'e constr =
+    { tag : string (** the tag in a tagged union *)
+    ; poly : bool (** polymorphic variant? *)
+    ; args : 'e list
+    }
+
+  type t = expr
+
+  (** [ _ -> assert false ] *)
+  val assert_false_clause : pat * expr
+
+  (** toplevel declartion (without the name) *)
+  type toplevel =
+    { pat : (string Arg.t * Type.t) list
+      (** paterns and their types. types should be optional but they really
+        help the error messages if the generated code is incorrect *)
+    ; type_ : Type.t (** useful to annotate the return types *)
+    ; body : t
+    }
+end
+
+module Module : sig
+  (** Generate OCaml modules with JS converters *)
+  module Name : sig
+    type t = private string
+
+    val of_string : string -> t
+  end
+
+  type 'a t =
+    { name : Name.t
+    ; bindings : 'a Named.t list
+    }
+
+  val empty : Name.t -> 'a t
+
+  type sig_ =
+    | Value of Type.t
+    | Type_decl of Type.decl
+    | Include of Name.t * (Type.t * Type.t) list
+
+  type impl =
+    | Type_decl of Type.decl
+    | Value of Expr.toplevel
+
+  val pp_sig : sig_ t -> unit Pp.t
+  val pp_impl : impl t -> unit Pp.t
+end

thirdparty/lsp/lsp/bin/ocaml/ml_create.ml

@@ -0,0 +1,78 @@
+open Import
+
+let f_name name = if name = "t" then "create" else sprintf "create_%s" name
+
+let need_unit =
+  List.exists ~f:(fun (f : Ml.Type.field) ->
+    match f.typ with
+    | Optional _ -> true
+    | _ -> false)
+;;
+
+let intf { Named.name; data = fields } =
+  let type_ =
+    let need_unit = need_unit fields in
+    let fields : Ml.Type.t Ml.Arg.t list =
+      List.map fields ~f:(fun (field : Ml.Type.field) ->
+        match field.typ with
+        | Optional t -> Ml.Arg.Optional (field.name, t)
+        | t -> Labeled (field.name, t))
+    in
+    let args : Ml.Type.t Ml.Arg.t list =
+      if need_unit
+      then
+        (* Gross hack because I was too lazy to allow patterns in toplevel
+           exprs *)
+        fields @ [ Ml.Arg.Unnamed Ml.Type.unit ]
+      else fields
+    in
+    Ml.Type.fun_ args (Ml.Type.name name)
+  in
+  let f_name = f_name name in
+  { Named.name = f_name; data = type_ }
+;;
+
+let impl { Named.name; data = fields } =
+  let make =
+    let fields =
+      List.map fields ~f:(fun (field : Ml.Type.field) ->
+        let open Ml.Expr in
+        field.name, Create (Ident field.name))
+    in
+    Ml.Expr.Create (Record fields)
+  in
+  let pat =
+    let need_unit = need_unit fields in
+    let fields =
+      List.map fields ~f:(fun (field : Ml.Type.field) ->
+        match field.typ with
+        | Optional t -> Ml.Arg.Optional (field.name, field.name), t
+        | t -> Ml.Arg.Labeled (field.name, field.name), t)
+    in
+    if need_unit
+    then
+      (* Gross hack because I was too lazy to allow patterns in toplevel
+         exprs *)
+      fields @ [ Unnamed "()", Ml.Type.unit ]
+    else fields
+  in
+  let body = { Ml.Expr.pat; type_ = Ml.Type.name name; body = make } in
+  let f_name = f_name name in
+  { Named.name = f_name; data = body }
+;;
+
+let impl_of_type (t : Ml.Type.decl Named.t) =
+  match (t.data : Ml.Type.decl) with
+  | Record fields ->
+    let create = impl { t with data = fields } in
+    [ { create with data = Ml.Module.Value create.data } ]
+  | _ -> []
+;;
+
+let intf_of_type (t : Ml.Type.decl Named.t) : Ml.Module.sig_ Named.t list =
+  match (t.data : Ml.Type.decl) with
+  | Record fields ->
+    let create = intf { t with data = fields } in
+    [ { create with data = Ml.Module.Value create.data } ]
+  | _ -> []
+;;

thirdparty/lsp/lsp/bin/ocaml/ml_create.mli

@@ -0,0 +1,3 @@
+(* Generate create functions with optional/labeled arguments *)
+val intf_of_type : Ml.Type.decl Named.t -> Ml.Module.sig_ Named.t list
+val impl_of_type : Ml.Type.decl Named.t -> Ml.Module.impl Named.t list

thirdparty/lsp/lsp/bin/ocaml/ml_kind.ml

@@ -0,0 +1,28 @@
+open! Import
+
+type 'a t =
+  { intf : 'a
+  ; impl : 'a
+  }
+
+type kind =
+  | Impl
+  | Intf
+
+let get { intf; impl } = function
+  | Impl -> impl
+  | Intf -> intf
+;;
+
+let make_both a = { intf = a; impl = a }
+
+let iter { intf; impl } ~f =
+  f intf;
+  f impl
+;;
+
+let map { intf; impl } ~f = { intf = f intf; impl = f impl }
+
+let both (type a b) (x : a t) (y : b t) : (a * b) t =
+  { intf = x.intf, y.intf; impl = x.impl, y.impl }
+;;

thirdparty/lsp/lsp/bin/ocaml/ocaml.ml

@@ -0,0 +1,681 @@
+open! Import
+open! Ts_types
+
+(* TypeScript to OCaml conversion pipeline. The goal of this pipeline is to do
+   the conversion in logical stages. Unfortunately, this doesn't quite work *)
+
+(* These declarations are all excluded because we don't support them or their
+   definitions are hand written *)
+let skipped_ts_decls =
+  [ "InitializedParams"
+  ; "NotificationMessage"
+  ; "RequestMessage"
+  ; "ResponseError"
+  ; "DocumentUri"
+  ; "ResponseMessage"
+  ; "Message"
+  ; "ErrorCodes"
+  ; "MarkedString"
+  ; "ProgressToken"
+  ; "ProgressParams"
+  ; "TextDocumentFilter"
+  ; "PrepareRenameResult"
+  ; "LSPAny"
+  ; "LSPObject"
+  ; "LSPArray"
+  ; "LSPErrorCodes"
+  ; "NotebookDocumentSyncOptions"
+  ; "NotebookDocumentFilter"
+  ; "NotebookDocumentSyncRegistrationOptions"
+  ; "URI"
+  ]
+;;
+
+(* XXX this is temporary until we support the [supportsCustomValues] field *)
+let with_custom_values =
+  [ "FoldingRangeKind"; "CodeActionKind"; "PositionEncodingKind"; "WatchKind" ]
+;;
+
+module Expanded = struct
+  (** The expanded form is still working with typescript types. However, all
+      "anonymous" records and sums have been hoisted to the toplevel. So there
+      is a 1-1 correspondence to the OCaml typse we are going to generate *)
+
+  [@@@ocaml.warning "-37"]
+
+  type binding =
+    | Record of Resolved.field list
+    | Interface of Resolved.interface
+    | Poly_enum of Resolved.typ list
+    | Alias of Resolved.typ
+
+  type t = binding Ml.Module.t
+
+  (** Every anonymous record *)
+  let new_binding_of_typ (x : Resolved.typ) : binding option =
+    let record = function
+      | [ { Named.name = _; data = Resolved.Pattern _ } ] -> None
+      | f -> Some (Record f)
+    in
+    match x with
+    | List (Record d) | Record d -> record d
+    | Sum [ _; Record d ] -> record d
+    | _ -> None
+  ;;
+
+  class discovered_types =
+    object
+      inherit [binding Named.t list] Resolved.fold as super
+
+      (** Every record valued field introduces a new type
+
+          TODO handle the case where two fields share a type *)
+      method! field f ~init =
+        let init =
+          match f.data with
+          | Pattern _ -> init
+          | Single { optional = _; typ } ->
+            (match new_binding_of_typ typ with
+             | None -> init
+             | Some data ->
+               let new_record = { f with data } in
+               if List.mem ~equal:Poly.equal init new_record
+               then init
+               else new_record :: init)
+        in
+        super#field f ~init
+    end
+
+  let bindings (r : Resolved.t) =
+    let t : binding Named.t =
+      let data =
+        match r.data with
+        | Enum_anon _ -> assert false
+        | Interface i -> Interface i
+        | Type typ ->
+          (match new_binding_of_typ typ with
+           | Some data -> data
+           | None -> Alias typ)
+      in
+      { data; name = "t" }
+    in
+    let init = [ t ] in
+    match r.data with
+    | Enum_anon _ -> assert false
+    | Type typ -> (new discovered_types)#typ typ ~init
+    | Interface intf -> (new discovered_types)#typ (Record intf.fields) ~init
+  ;;
+
+  let of_ts (r : Resolved.t) : t =
+    let name = Ml.Module.Name.of_string (String.capitalize_ascii r.name) in
+    { Ml.Module.name; bindings = bindings r }
+  ;;
+end
+
+module Json = Json_gen
+
+module Module : sig
+  open Ml
+
+  type t = (Module.sig_ Module.t, Module.impl Module.t) Kind.pair
+
+  val add_private_values : t -> Expr.toplevel Named.t list -> t
+  val type_decls : Module.Name.t -> Type.decl Named.t list Kind.Map.t -> t
+
+  (** Use Json.Nullable_option or Json.Assoc.t where appropriate *)
+  val use_json_conv_types : t -> t
+
+  (** Rename fields that are also OCaml keywords *)
+  val rename_invalid_fields : Ml.Kind.t -> Type.decl -> Type.decl
+
+  val pp : t -> unit Pp.t Kind.Map.t
+end = struct
+  module Module = Ml.Module
+
+  type t = (Module.sig_ Module.t, Module.impl Module.t) Ml.Kind.pair
+
+  let type_decls name (type_decls : Ml.Type.decl Named.t list Ml.Kind.Map.t) : t =
+    let module_ bindings = { Ml.Module.name; bindings } in
+    let intf : Module.sig_ Module.t =
+      List.map type_decls.intf ~f:(fun (td : Ml.Type.decl Named.t) ->
+        { td with Named.data = (Ml.Module.Type_decl td.data : Ml.Module.sig_) })
+      |> module_
+    in
+    let impl =
+      List.map type_decls.impl ~f:(fun (td : Ml.Type.decl Named.t) ->
+        { td with Named.data = Ml.Module.Type_decl td.data })
+      |> module_
+    in
+    { Ml.Kind.intf; impl }
+  ;;
+
+  let add_private_values (t : t) bindings : t =
+    let bindings =
+      List.map bindings ~f:(fun (v : _ Named.t) ->
+        { v with Named.data = Ml.Module.Value v.data })
+    in
+    let impl = { t.impl with bindings = t.impl.bindings @ bindings } in
+    { t with impl }
+  ;;
+
+  let json_assoc_t = Ml.Path.Dot (Dot (Ident "Json", "Assoc"), "t")
+
+  let rename_invalid_fields =
+    let map (kind : Ml.Kind.t) =
+      let open Ml.Type in
+      object (self)
+        inherit [unit, unit] Ml.Type.mapreduce as super
+        method empty = ()
+        method plus () () = ()
+
+        method! field x f =
+          let f =
+            if Ml.is_kw f.name
+            then (
+              let attrs =
+                match kind with
+                | Impl -> ("key", [ sprintf "%S" f.name ]) :: f.attrs
+                | Intf -> f.attrs
+              in
+              { f with name = f.name ^ "_"; attrs })
+            else f
+          in
+          super#field x f
+
+        method! assoc x k v = self#t x (App (Path json_assoc_t, [ k; v ]))
+      end
+    in
+    fun kind t -> (map kind)#decl () t |> fst
+  ;;
+
+  let use_json_conv_types =
+    let map =
+      let open Ml.Type in
+      object (self)
+        inherit [unit, unit] Ml.Type.mapreduce as super
+        method empty = ()
+        method plus () () = ()
+
+        method! optional x t =
+          if t = Json_gen.json_t
+          then super#optional x t
+          else (
+            let opt = Ml.Path.Dot (Dot (Ident "Json", "Nullable_option"), "t") in
+            self#t x (App (Path opt, [ t ])))
+
+        method! field x f =
+          let f =
+            match f.typ with
+            | Optional t ->
+              if t = Json_gen.json_t
+              then { f with attrs = ("yojson.option", []) :: f.attrs }
+              else
+                { f with
+                  attrs =
+                    ("default", [ "None" ])
+                    :: ("yojson_drop_default", [ "( = )" ])
+                    :: f.attrs
+                }
+            | _ -> f
+          in
+          super#field x f
+
+        method! assoc x k v = self#t x (App (Path json_assoc_t, [ k; v ]))
+      end
+    in
+    fun (t : t) ->
+      let impl =
+        let bindings =
+          List.map t.impl.bindings ~f:(fun (x : _ Named.t) ->
+            let data =
+              match (x.data : Module.impl) with
+              | Type_decl decl -> Ml.Module.Type_decl (map#decl () decl |> fst)
+              | x -> x
+            in
+            { x with data })
+        in
+        { t.impl with bindings }
+      in
+      { t with impl }
+  ;;
+
+  let pp (t : t) ~kind =
+    match (kind : Ml.Kind.t) with
+    | Intf -> Ml.Module.pp_sig t.intf
+    | Impl -> Ml.Module.pp_impl t.impl
+  ;;
+
+  let pp t = { Ml.Kind.intf = pp t ~kind:Intf; impl = pp t ~kind:Impl }
+end
+
+let enum_module ~allow_other ({ Named.name; data = constrs } as t) =
+  let json_bindings = Json_gen.Enum.conv ~allow_other ~poly:false { t with name = "t" } in
+  let t =
+    let data =
+      let constrs = List.map constrs ~f:(fun (name, _) -> Ml.Type.constr ~name []) in
+      let constrs =
+        if allow_other
+        then
+          (* [String] is a hack. It could be a differnt type, but it isn't in
+             practice *)
+          constrs @ [ Ml.Type.constr ~name:"Other" [ Ml.Type.Prim String ] ]
+        else constrs
+      in
+      Ml.Type.Variant constrs
+    in
+    { Named.name = "t"; data }
+  in
+  let type_decls = Ml.Kind.Map.make_both [ t ] in
+  let module_ = Module.type_decls (Ml.Module.Name.of_string name) type_decls in
+  Module.add_private_values module_ json_bindings
+;;
+
+module Entities = struct
+  type t = (Ident.t * Resolved.t) list
+
+  let find db e : _ Named.t =
+    match List.assoc db e with
+    | Some s -> s
+    | None -> Code_error.raise "Entities.find: unable to find" [ "e", Ident.to_dyn e ]
+  ;;
+
+  let of_map map ts =
+    List.map ts ~f:(fun (r : Resolved.t) -> String.Map.find_exn map r.name, r)
+  ;;
+
+  let rev_find (db : t) (resolved : Resolved.t) : Ident.t =
+    match
+      List.filter_map db ~f:(fun (id, r) ->
+        if r.name = resolved.name then Some id else None)
+    with
+    | [] -> Code_error.raise "rev_find: resolved not found" []
+    | [ x ] -> x
+    | _ :: _ -> Code_error.raise "re_vind: duplicate entries" []
+  ;;
+end
+
+module Mapper : sig
+  (* Convert typescript types to OCaml types *)
+
+  val make_typ : Entities.t -> Resolved.typ Named.t -> Ml.Type.t
+
+  type literal_field =
+    { field_name : string
+    ; literal_value : string
+    }
+
+  (** Map a TS record into an OCaml record. Literal valued fields such as kind:
+      'foo' are extracted into a separate list *)
+  val record_
+    :  Entities.t
+    -> Resolved.field list Named.t
+    -> Ml.Type.decl Named.t * literal_field list
+
+  (** Extract all untagged unions in field position. These will be turned into
+      polymorphic variants using a naming scheme for the tags. *)
+  val extract_poly_vars : Ml.Type.decl -> Ml.Type.decl * Ml.Type.constr list Named.t list
+end = struct
+  type literal_field =
+    { field_name : string
+    ; literal_value : string
+    }
+
+  module Type = Ml.Type
+
+  let is_same_as_json =
+    let constrs =
+      [ Prim.Null; String; Bool; Number; Object; List ]
+      |> List.map ~f:(fun s -> Resolved.Ident s)
+    in
+    fun set -> List.for_all constrs ~f:(fun e -> List.mem set e ~equal:Poly.equal)
+  ;;
+
+  let id = Type.name "Jsonrpc.Id.t"
+
+  let is_same_as_id =
+    let sort = List.sort ~compare:Poly.compare in
+    let constrs =
+      [ Prim.String; Number ] |> List.map ~f:(fun s -> Resolved.Ident s) |> sort
+    in
+    fun cs -> List.equal ( = ) constrs (sort cs)
+  ;;
+
+  (* Any type that includes null needs to be extracted to be converted to an
+     option *)
+  let remove_null cs =
+    let is_null x =
+      match x with
+      | Resolved.Ident Prim.Null -> Either.Left x
+      | _ -> Right x
+    in
+    let nulls, non_nulls = List.partition_map ~f:is_null cs in
+    match nulls with
+    | [] -> `No_null_present
+    | _ :: _ :: _ -> assert false
+    | [ _ ] -> `Null_removed non_nulls
+  ;;
+
+  let make_typ db { Named.name; data = t } =
+    let rec type_ topmost_field_name (t : Resolved.typ) =
+      match t with
+      | Ident Uinteger -> Type.int (* XXX shall we use a dedicated uinteger eventually? *)
+      | Ident Number -> Type.int
+      | Ident String -> Type.string
+      | Ident Bool -> Type.bool
+      | Ident Object -> Type.json_object
+      | Ident Self -> Type.t (* XXX wrong *)
+      | Ident Any -> Type.json
+      | Ident Null -> assert false
+      | Ident List -> Type.list Type.json
+      | Ident Uri | Ident (Resolved { id = _; name = "URI" }) ->
+        Type.module_t "DocumentUri"
+      | Ident (Resolved { id = _; name = "LSPAny" }) -> Type.json
+      | Ident (Resolved { id = _; name = "LSPObject" }) -> Type.json_object
+      | Ident (Resolved r) ->
+        let entity = Entities.find db r in
+        Type.module_t entity.name
+      | List (Ident (Uinteger | Number)) when topmost_field_name = Some "data" ->
+        Type.array Type.int
+      | List t -> Type.list (type_ topmost_field_name t)
+      | Tuple ts -> Type.Tuple (List.map ~f:(type_ topmost_field_name) ts)
+      | Sum s -> sum topmost_field_name s
+      | App _ | Literal _ -> Type.void
+      | Record r -> record r
+    and sum topmost_field_name s =
+      if is_same_as_json s
+      then Type.json
+      else (
+        match remove_null s with
+        | `No_null_present -> if is_same_as_id s then id else poly topmost_field_name s
+        | `Null_removed [ s ] -> Type.Optional (type_ topmost_field_name s)
+        | `Null_removed [] -> assert false
+        | `Null_removed cs -> Type.Optional (sum topmost_field_name cs))
+    and simplify_record (fields : Resolved.field list) =
+      (* A record with only a pattern field is simplified to an association
+         list *)
+      match fields with
+      | [ { Named.name; data = Pattern { pat; typ } } ] ->
+        let topmost_field_name = Some name in
+        let key = type_ topmost_field_name pat in
+        let data = type_ topmost_field_name typ in
+        Some (Type.assoc_list ~key ~data)
+      | [] -> Some Type.json_object
+      | _ -> None
+    and record fields =
+      match simplify_record fields with
+      | None -> Type.name name
+      | Some a -> a
+    and poly topmost_field_name s : Ml.Type.t =
+      let type_ = type_ topmost_field_name in
+      try
+        Poly_variant
+          (List.map s ~f:(fun t ->
+             let name, constrs =
+               match (t : Resolved.typ) with
+               | Ident Self | Ident Null -> assert false
+               | Ident String -> "String", [ type_ t ]
+               | Ident Number -> "Int", [ type_ t ]
+               | Ident Object -> "Assoc", [ type_ t ]
+               | Ident Bool -> "Bool", [ type_ t ]
+               | List _ | Ident List -> "List", [ type_ t ]
+               | Ident (Resolved r) -> (Entities.find db r).name, [ type_ t ]
+               | Tuple [ Ident Uinteger; Ident Uinteger ] -> "Offset", [ type_ t ]
+               | Literal (String x) -> x, []
+               | Record _ ->
+                 let topmost_field_name = Option.value_exn topmost_field_name in
+                 topmost_field_name, [ type_ t ]
+               | _ -> raise Exit
+             in
+             Type.constr ~name constrs))
+      with
+      | Exit -> Type.unit
+    in
+    type_ (Some name) t
+  ;;
+
+  let make_field db (field : Resolved.field) =
+    match field.data with
+    | Pattern { pat; typ } ->
+      let key = make_typ db { Named.name = field.name; data = pat } in
+      let data = make_typ db { Named.name = field.name; data = typ } in
+      let typ = Type.assoc_list ~key ~data in
+      Either.Left (Ml.Type.field typ ~name:field.name)
+    | Single { typ = Literal s; optional = false } ->
+      let literal_value =
+        match s with
+        | String s -> s
+        | _ -> assert false
+      in
+      Right { literal_value; field_name = field.name }
+    | Single { typ; optional } ->
+      let typ = make_typ db { Named.name = field.name; data = typ } in
+      let typ = if optional then Type.Optional typ else typ in
+      Left (Ml.Type.field typ ~name:field.name)
+  ;;
+
+  let record_ db { Named.name; data = (fields : Resolved.field list) } =
+    let data, literals =
+      match fields with
+      | [ { Named.name; data = Pattern { pat; typ } } ] ->
+        let key = make_typ db { Named.name; data = pat } in
+        let data = make_typ db { Named.name; data = typ } in
+        Type.Alias (Type.assoc_list ~key ~data), []
+      | [] -> Type.Alias Type.json_object, []
+      | _ ->
+        let fields, literals = List.partition_map fields ~f:(make_field db) in
+        Type.Record fields, literals
+    in
+    { Named.name; data }, literals
+  ;;
+
+  let extract_poly_vars s =
+    let extract =
+      object (self)
+        inherit
+          [string option, Ml.Type.constr list Named.t list] Ml.Type.mapreduce as super
+
+        method empty = []
+
+        (* TODO grossly slow *)
+        method plus x y = x @ y
+
+        method! field _ (f : Ml.Type.field) =
+          let env = Some f.name in
+          super#field env f
+
+        method! poly_variant env constrs =
+          match env with
+          | None -> super#poly_variant env constrs
+          | Some name ->
+            (* This hack is needed to avoid collision with user visible types
+               that we might introduce *)
+            let name = name ^ "_pvar" in
+            let replacement = Ml.Type.name name in
+            let constrs, m = self#fold_left_map ~f:(self#constr env) constrs in
+            replacement, self#plus m [ { Named.name; data = constrs } ]
+      end
+    in
+    extract#decl None s
+  ;;
+end
+
+module Gen : sig
+  val module_ : Entities.t -> Expanded.binding Ml.Module.t -> Module.t
+end = struct
+  module Type = Ml.Type
+
+  let type_ db ({ Named.name; data = _ } as t) =
+    let main_type =
+      let typ = Mapper.make_typ db t in
+      { Named.name; data = Type.Alias typ }
+    in
+    [ main_type ]
+  ;;
+
+  let record db ({ Named.name = _; data = _ } as t) =
+    let main_type, literals = Mapper.record_ db t in
+    Some (main_type, literals)
+  ;;
+
+  let poly_enum { Named.name; data = _ } : Type.decl Named.t list =
+    [ { Named.name; data = Type.Alias Type.unit } ]
+  ;;
+
+  let poly_enum_conv (t : _ Named.t) =
+    if List.for_all t.data ~f:(fun (c : Ml.Type.constr) -> List.is_empty c.args)
+    then
+      (* This is equivalent to an enum *)
+      List.map t.data ~f:(fun (c : Ml.Type.constr) -> c.name, Literal.String c.name)
+      |> Named.set_data t
+      |> Json_gen.Enum.conv ~allow_other:false ~poly:true
+    else [ Json_gen.Poly_variant.of_json t; Json_gen.Poly_variant.to_json t ]
+  ;;
+
+  (* This is the more complex case *)
+
+  let module_ db { Ml.Module.name; bindings } : Module.t =
+    let type_decls =
+      let add_record = function
+        | None -> []
+        | Some (decl, literals) -> [ `Record (decl, literals) ]
+      in
+      let add_else = List.map ~f:(fun x -> `Type x) in
+      List.concat_map bindings ~f:(fun (r : Expanded.binding Named.t) ->
+        match r.data with
+        | Record data -> record db { r with data } |> add_record
+        | Interface data -> record db { r with data = data.fields } |> add_record
+        | Poly_enum data -> poly_enum { r with data } |> add_else
+        | Alias data -> type_ db { r with data } |> add_else)
+    in
+    let intf : Ml.Module.sig_ Named.t list =
+      List.map type_decls ~f:(function
+        | `Record (t, _) -> t
+        | `Type t -> t)
+      |> List.concat_map ~f:(fun (td : Ml.Type.decl Named.t) ->
+        let td = { td with data = Module.rename_invalid_fields Intf td.data } in
+        [ { td with Named.data = (Ml.Module.Type_decl td.data : Ml.Module.sig_) } ]
+        @ Ml_create.intf_of_type td)
+    in
+    let impl : Ml.Module.impl Named.t list =
+      (* TODO we should make sure to handle duplicate variants extracted *)
+      List.concat_map type_decls ~f:(fun d ->
+        let d, literal_wrapper =
+          match d with
+          | `Record (l, [ lw ]) -> l, Some lw
+          | `Record (l, []) -> l, None
+          | `Record (_, _ :: _) ->
+            assert false
+            (* we don't support multiple literals in a single record for
+               now *)
+          | `Type l -> l, None
+        in
+        let typ_, poly_vars = Mapper.extract_poly_vars (Named.data d) in
+        let poly_vars_and_convs =
+          List.concat_map poly_vars ~f:(fun pv ->
+            let decl =
+              Named.map pv ~f:(fun decl ->
+                Ml.Module.Type_decl (Alias (Poly_variant decl)))
+            in
+            let json_conv =
+              poly_enum_conv pv |> List.map ~f:(Named.map ~f:(fun v -> Ml.Module.Value v))
+            in
+            decl :: json_conv)
+        in
+        let typ_ = { d with data = typ_ } in
+        let literal_wrapper =
+          match literal_wrapper with
+          | None -> []
+          | Some { field_name; literal_value } ->
+            Json_gen.make_literal_wrapper_conv
+              ~field_name
+              ~literal_value
+              ~type_name:typ_.name
+        in
+        let typ_ = { typ_ with data = Module.rename_invalid_fields Impl typ_.data } in
+        let json_convs_for_t =
+          match d.data with
+          | Alias (Poly_variant data) ->
+            poly_enum_conv { d with Named.data }
+            |> List.map ~f:(Named.map ~f:(fun v -> Ml.Module.Value v))
+          | _ -> []
+        in
+        poly_vars_and_convs
+        @ [ { typ_ with data = Ml.Module.Type_decl typ_.data } ]
+        @ json_convs_for_t
+        @ Ml_create.impl_of_type typ_
+        @ literal_wrapper)
+    in
+    let module_ bindings = { Ml.Module.name; bindings } in
+    { Ml.Kind.intf = module_ intf; impl = module_ impl }
+  ;;
+end
+
+(* extract all resovled identifiers *)
+class name_idents =
+  object
+    inherit [Ident.t list] Resolved.fold
+
+    method! ident i ~init =
+      match i with
+      | Resolved r -> r :: init
+      | _ -> init
+  end
+
+let resolve_typescript (ts : Unresolved.t list) =
+  let ts, db = Typescript.resolve_all ts in
+  let db = Entities.of_map db ts in
+  match
+    let idents = new name_idents in
+    Ident.Top_closure.top_closure
+      ts
+      ~key:(fun x -> Entities.rev_find db x)
+      ~deps:(fun x -> idents#t x ~init:[] |> List.map ~f:(Entities.find db))
+  with
+  | Error cycle ->
+    let cycle = List.map cycle ~f:(fun (x : Resolved.t) -> x.name) in
+    Code_error.raise "Unexpected cycle" [ "cycle", Dyn.(list string) cycle ]
+  | Ok ts -> db, ts
+;;
+
+let of_resolved_typescript db (ts : Resolved.t list) =
+  let simple_enums, everything_else =
+    List.filter_partition_map ts ~f:(fun (t : Resolved.t) ->
+      if List.mem skipped_ts_decls t.name ~equal:String.equal
+      then Skip
+      else (
+        match t.data with
+        | Enum_anon data -> Left { t with data }
+        | Interface _ | Type _ -> Right t))
+  in
+  let simple_enums =
+    List.map simple_enums ~f:(fun (t : _ Named.t) ->
+      (* "open" enums need an `Other constructor *)
+      let allow_other = List.mem ~equal:String.equal with_custom_values t.name in
+      let data =
+        List.filter_map t.data ~f:(fun (constr, v) ->
+          match (v : Ts_types.Enum.case) with
+          | Literal l -> Some (constr, l)
+          | Alias _ ->
+            (* TODO we don't handle these for now *)
+            None)
+      in
+      enum_module ~allow_other { t with data })
+  in
+  let everything_else =
+    List.map everything_else ~f:(fun (t : _ Named.t) ->
+      let mod_ = Expanded.of_ts t in
+      Gen.module_ db mod_)
+  in
+  simple_enums @ everything_else
+  |> List.map ~f:(fun (decl : _ Ml.Kind.pair) ->
+    let decl =
+      let intf = Json_gen.add_json_conv_for_t decl.intf in
+      { decl with intf }
+    in
+    Module.use_json_conv_types decl)
+;;
+
+let of_typescript ts =
+  let db, ts = resolve_typescript ts in
+  of_resolved_typescript db ts
+;;

thirdparty/lsp/lsp/bin/ocaml/ocaml.mli

@@ -0,0 +1,7 @@
+module Module : sig
+  type t = (Ml.Module.sig_ Ml.Module.t, Ml.Module.impl Ml.Module.t) Ml.Kind.pair
+
+  val pp : t -> unit Pp.t Ml.Kind.Map.t
+end
+
+val of_typescript : Ts_types.Unresolved.t list -> Module.t list

thirdparty/lsp/lsp/bin/ocaml/w.ml

@@ -0,0 +1,199 @@
+open Import
+open Pp.O
+open Pp
+
+type t = unit Pp.t
+type w = t
+
+(* This module contains all the writing primitives *)
+
+let ident = verbatim
+let i = verbatim
+let quoted s = i (sprintf "%S" s)
+
+let surround delim a =
+  let start, finish =
+    match delim with
+    | `Paren -> i "(", i ")"
+    | `Curly -> i "{", i "}"
+    | `Square -> i "[", i "]"
+  in
+  Pp.concat [ start; a; finish ]
+;;
+
+module Json = struct
+  let invalid_pat name = ident "json", Pp.textf "Json.error \"invalid %s\" json" name
+  let typ = "Json.t"
+
+  module Literal = struct
+    let str n = sprintf "`String %S" n
+    let int i = sprintf "`Int (%d)" i
+    let null = "`Null"
+    let bool b = sprintf "`Bool %b" b
+  end
+
+  let str = sprintf "`String %s"
+  let int = sprintf "`Int %s"
+  let bool = sprintf "`Bool %s"
+end
+
+module Gen = struct
+  let record ~delim fields =
+    let sep = Pp.concat [ Pp.verbatim ";"; Pp.newline ] in
+    Pp.text "{"
+    ++ Pp.concat_map ~sep fields ~f:(fun (name, f) ->
+      Pp.concat [ Pp.textf "%s %s " name delim; f ])
+    ++ Pp.verbatim "}"
+  ;;
+
+  let clause ~delim l r = Pp.concat [ l; Pp.verbatim (sprintf " %s " delim); r ]
+end
+
+module Attr = struct
+  type t =
+    { name : string
+    ; payload : w list
+    }
+
+  let make name payload = { name; payload }
+
+  let pp kind { name; payload } =
+    let kind =
+      match kind with
+      | `Field -> "@"
+      | `Type -> "@@"
+    in
+    Pp.concat [ i kind; i name; Pp.space; Pp.concat ~sep:Pp.space payload ]
+    |> surround `Square
+  ;;
+end
+
+module Type = struct
+  let string = i "string"
+  let int = i "int"
+  let name = i
+  let bool = i "bool"
+  let gen_decl kw name body = Pp.concat [ Pp.textf "%s %s =" kw name; Pp.newline; body ]
+  let and_ name body = gen_decl "and" name body
+  let decl name body = gen_decl "type" name body
+  let record fields = Gen.record ~delim:":" fields
+
+  let field_attrs ~field ~attrs =
+    match attrs with
+    | [] -> field
+    | attrs ->
+      let attrs = Pp.concat_map attrs ~sep:Pp.space ~f:(Attr.pp `Field) in
+      Pp.concat [ field; Pp.space; attrs ]
+  ;;
+
+  let var typ = Pp.textf "'%s" typ
+
+  let app typ = function
+    | [] -> assert false
+    | [ x ] -> Pp.concat [ x; Pp.space; typ ]
+    | xs ->
+      let args =
+        let sep = Pp.verbatim "," in
+        Pp.concat [ Pp.verbatim "("; Pp.concat ~sep xs; Pp.verbatim ")" ]
+      in
+      Pp.concat [ args; Pp.space; typ ]
+  ;;
+
+  let tuple fields =
+    let sep = i "*" in
+    i "(" ++ Pp.concat ~sep fields ++ i ")"
+  ;;
+
+  let rec_decls xs =
+    match xs with
+    | [] -> Pp.concat []
+    | (name, body) :: xs ->
+      decl name body
+      ++ newline
+      ++ Pp.concat_map xs ~sep:Pp.newline ~f:(fun (name, body) -> and_ name body)
+  ;;
+
+  let deriving td ~record =
+    let fields = if record then space ++ i "[@@yojson.allow_extra_fields]" else space in
+    Pp.concat
+      [ td
+      ; Pp.newline
+      ; Pp.text "[@@deriving_inline yojson]"
+      ; fields
+      ; space
+      ; Pp.text "[@@@end]"
+      ]
+  ;;
+
+  let opt_attr = ident "option [@yojson.option]"
+  let opt_field f = Pp.seq f opt_attr
+  let default f def = Pp.concat [ f; ident "[@default "; ident def; ident "]" ]
+  let key name = concat [ ident "[@key "; quoted name; ident "]" ]
+
+  let gen_variant ~poly constrs =
+    let sep = Pp.concat [ Pp.newline; i "| " ] in
+    Pp.concat_map constrs ~sep ~f:(fun (name, arg) ->
+      let name =
+        let name = String.capitalize_ascii name in
+        if poly then "`" ^ name else name
+      in
+      match arg with
+      | [] -> i name
+      | xs ->
+        let xs =
+          match xs with
+          | [ x ] -> x
+          | xs -> tuple xs
+        in
+        Gen.clause ~delim:"of" (ident name) xs)
+  ;;
+
+  let poly constrs = concat [ i "["; gen_variant ~poly:true constrs; i "]" ]
+  let variant constrs = gen_variant ~poly:false constrs
+end
+
+let gen_module kw name body =
+  Pp.concat
+    [ Pp.textf "module %s %s" name kw
+    ; Pp.newline
+    ; body
+    ; newline
+    ; verbatim "end"
+    ; newline
+    ]
+;;
+
+module Sig = struct
+  let module_ name body = gen_module ": sig" name body
+
+  let include_ name destructive_subs =
+    let inc_ = Pp.textf "include %s" name in
+    match destructive_subs with
+    | [] -> inc_
+    | substs ->
+      let substs =
+        let sep = Pp.text " and " in
+        Pp.concat_map ~sep substs ~f:(fun (l, r) ->
+          Pp.concat
+            [ Pp.text "type"; Pp.space; l; Pp.space; Pp.verbatim ":="; Pp.space; r ])
+      in
+      Pp.concat [ inc_; Pp.space; Pp.text "with"; Pp.space; substs ]
+  ;;
+
+  let val_ name b =
+    let sep = Pp.concat [ space; i "->"; space ] in
+    let b = Pp.concat ~sep b in
+    Pp.concat [ textf "val %s : " name; b; Pp.newline ]
+  ;;
+
+  let assoc k v = Pp.concat [ Type.tuple [ k; v ]; Pp.space; i "list" ]
+end
+
+let warnings codes = seq (textf "[@@@warning %S]" codes) newline
+
+let opens names =
+  Pp.concat_map names ~f:(fun name -> Pp.concat [ textf "open! %s" name; newline ])
+;;
+
+let module_ name body = gen_module "= struct" name body
+let record fields = Gen.record ~delim:"=" fields