Internal

dune-project

@@ -1,6 +1,7 @@
 (lang dune 3.0)
 (using cinaps 1.0)
 (name lsp)
+(version "1.19.0+jst")
 
 (implicit_transitive_deps false)
 
@@ -38,7 +39,7 @@ possible and does not make any assumptions about IO.
   (uutf (>= 1.0.2))
   (odoc :with-doc)
   (ocaml (>= 4.14))
-  (ppx_yojson_conv :with-dev-setup)))
+  ppx_yojson_conv))
 
 (package
  (name ocaml-lsp-server)
@@ -56,7 +57,7 @@ possible and does not make any assumptions about IO.
   dyn
   stdune
   (fiber (and (>= 3.1.1) (< 4.0.0)))
-  (ocaml (and (>= 5.3) (< 5.4)))
+  ocaml
   xdg
   ordering
   dune-build-info
@@ -70,13 +71,18 @@ possible and does not make any assumptions about IO.
   (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)))
+  (odoc-parser (= 2.0.0))
+  (merlin-lib (= "5.2.1-502+jst"))
+  ppx_yojson_conv
+  core_unix
+  async
+  cmarkit))
 
 (package
  (name jsonrpc)
  (synopsis "Jsonrpc protocol implemenation")
  (description "See https://www.jsonrpc.org/specification")
  (depends
   (ocaml (>= 4.08))
-  (odoc :with-doc)))
+  (odoc :with-doc)
+  (yojson (and (>= 2.0.0) (< 3.0.0)))))

fiber-async/src/dune

@@ -0,0 +1,6 @@
+(library
+  (name fiber_async)
+  (inline_tests)
+  (libraries async async_kernel base core fiber stdune)
+  (preprocess
+    (pps ppx_jane)))

fiber-async/src/fiber_async.ml

@@ -0,0 +1,55 @@
+open Core
+open Async
+
+module Fiber = struct
+  include Fiber
+
+  include Monad.Make (struct
+      include Fiber
+
+      let map = `Custom map
+    end)
+end
+
+(* Fiber-local storage. [Univ_map.Key] behind the scenes. *)
+let (key : (Fiber.fill -> unit) option Fiber.Var.t) = Fiber.Var.create ()
+
+(* This solution is adapted from the [Fiber_lwt] module in Dune. When the fiber scheduler
+   reaches a [Fiber.Ivar.read] for an unfilled [Fiber.Ivar.t], it stalls, and when resumed
+   it must be give a [Fiber.Fill (ivar, value)] for that ivar so it can enqueue jobs
+   waiting on its result. If the [Fiber.Ivar.t] is filled but the fill is not communicated
+   to the scheduler, the scheduler will not know the jobs waiting on it are now ready to
+   run. Therefore, when we create a [Fiber.Ivar.t] inside [fiber_of_deferred] to hold the
+   value when the deferred is filled, we also need some way to communicate with the
+   fiber's scheduler. We do this via a pipe that the scheduler provides in fiber-local
+   storage, but for that to work the fiber's scheduler must be the one produced by the
+   complementary [deferred_of_fiber]. *)
+
+let fiber_of_deferred (type a) (deferred : a Deferred.t) : a Fiber.t =
+  let ivar = Fiber.Ivar.create () in
+  match%bind.Fiber Fiber.Var.get key with
+  | None -> failwith "[fiber_of_deferred] invoked outside of [deferred_of_fiber]"
+  | Some fill ->
+    match fill with
+    | None -> failwith "[fiber_of_deferred] invoked outside of [deferred_of_fiber]"
+    | Some fill ->
+      upon deferred (fun value -> fill (Fiber.Fill (ivar, value)));
+      Fiber.Ivar.read ivar
+;;
+
+let deferred_of_fiber fiber () =
+  let reader, writer = Pipe.create () in
+  let fiber =
+    Fiber.Var.set key (Some (Pipe.write_without_pushback writer)) (fun () -> fiber)
+  in
+  let rec loop witness = function
+    | Fiber.Scheduler.Done x -> return x
+    | Fiber.Scheduler.Stalled _ ->
+      let%bind fill = Pipe.read_exn reader in
+      loop witness (Fiber.Scheduler.advance witness [ fill ])
+  in
+  let step = Fiber.Scheduler.start fiber in
+  match step with
+  | Done x -> return x
+  | Stalled witness -> loop witness step
+;;

fiber-async/src/fiber_async.mli

@@ -0,0 +1,26 @@
+open Core
+open Async
+
+(** Interoperation between fibers and Async. This library assumes that the outer program
+    is running with Async and that the fibers will be interpreted by [deferred_of_fiber].
+
+    The most important difference between fibers and deferreds is that fibers are just
+    continuations and do not store the value they compute, so if you bind twice on a given
+    fiber the computation will be run twice. A [Fiber.Ivar.t] can be used to save the
+    result of a computation. *)
+
+module Fiber : sig
+  include module type of struct
+    include Fiber
+  end
+
+  include Monad.S with type 'a t := 'a t
+end
+
+(** Convert a fiber to a computation that returns a deferred when run. *)
+val deferred_of_fiber : 'a Fiber.t -> (unit -> 'a Deferred.t)
+
+(** Convert a deferred to a fiber that stores the result in a [Fiber.Ivar.t]. This fiber
+    can only be interpreted by [deferred_of_fiber] - using a different scheduler to run it
+    will fail. *)
+val fiber_of_deferred : 'a Deferred.t -> 'a Fiber.t

jsonrpc-fiber/src/import.ml

@@ -77,7 +77,7 @@ end
 let sprintf = Printf.sprintf
 
 let () =
-  Printexc.register_printer (function
+  (Printexc.register_printer [@ocaml.alert "-unsafe_multidomain"]) (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))

jsonrpc-fiber/src/jsonrpc_fiber.ml

@@ -35,7 +35,7 @@ end
 exception Stopped of Request.t
 
 let () =
-  Printexc.register_printer (function
+  (Printexc.register_printer [@ocaml.alert "-unsafe_multidomain"]) (function
     | Stopped req ->
       let json = Request.yojson_of_t req in
       Some ("Session closed. Request will not be answered. " ^ Json.to_pretty_string json)
@@ -137,11 +137,11 @@ struct
   ;;
 
   let create
-        ?(on_request = on_request_fail)
-        ?(on_notification = on_notification_fail)
-        ~name
-        chan
-        state
+    ?(on_request = on_request_fail)
+    ?(on_notification = on_notification_fail)
+    ~name
+    chan
+    state
     =
     let pending = Id.Table.create 10 in
     { chan
@@ -274,8 +274,8 @@ struct
       let* () =
         Fiber.fork_and_join_unit
           (fun () ->
-             let* () = loop () in
-             Fiber.Pool.stop later)
+            let* () = loop () in
+            Fiber.Pool.stop later)
           (fun () -> Fiber.Pool.run later)
       in
       close t)

jsonrpc-fiber/src/jsonrpc_fiber.mli

@@ -14,8 +14,8 @@ 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 *)
+(** 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
 

jsonrpc-fiber/test/dune

@@ -12,10 +12,10 @@
   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
+  ppx_expect.runtime_types
   stdune
   yojson)
  (preprocess

jsonrpc-fiber/test/jsonrpc_fiber_tests.ml

@@ -41,9 +41,7 @@ let%expect_test "start and stop server" =
     Fiber.fork_and_join_unit (fun () -> run) (fun () -> Jrpc.stop jrpc)
   in
   let () = Fiber_test.test Dyn.opaque run in
-  [%expect
-    {|
-    <opaque> |}]
+  [%expect {| <opaque> |}]
 ;;
 
 let%expect_test "server accepts notifications" =
@@ -66,7 +64,8 @@ let%expect_test "server accepts notifications" =
   [%expect
     {|
     received notification
-    <opaque> |}]
+    <opaque>
+    |}]
 ;;
 
 let of_ref ref =
@@ -104,7 +103,8 @@ let%expect_test "serving requests" =
   [%expect
     {|
     { "id": 1, "jsonrpc": "2.0", "result": "response" }
-    <opaque> |}]
+    <opaque>
+    |}]
 ;;
 
 (* The current client/server implement has no concurrent handling of requests.
@@ -191,7 +191,8 @@ let%expect_test "concurrent requests" =
     { "id": "initial", "jsonrpc": "2.0", "result": null }
     waiter: received response:
     { "id": 100, "jsonrpc": "2.0", "result": 42 }
-    [FAIL] unexpected Never raised |}]
+    [FAIL] unexpected Never raised
+    |}]
 ;;
 
 let%expect_test "test from jsonrpc_test.ml" =
@@ -260,7 +261,8 @@ let%expect_test "test from jsonrpc_test.ml" =
     [ { exn = "Failure(\"special failure\")"; backtrace = "" } ]
     <opaque>
     { "id": 10, "jsonrpc": "2.0", "result": 1 }
-    { "id": "testing", "jsonrpc": "2.0", "result": 2 } |}]
+    { "id": "testing", "jsonrpc": "2.0", "result": 2 }
+    |}]
 ;;
 
 let%expect_test "cancellation" =
@@ -338,5 +340,6 @@ let%expect_test "cancellation" =
     client: got server ack, cancelling request
     request has been cancelled
     server: got client ack, sending response
-    <opaque> |}]
+    <opaque>
+    |}]
 ;;

jsonrpc.opam

@@ -1,5 +1,6 @@
 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
+version: "1.19.0+jst"
 synopsis: "Jsonrpc protocol implemenation"
 description: "See https://www.jsonrpc.org/specification"
 maintainer: ["Rudi Grinberg <[email protected]>"]
@@ -22,6 +23,7 @@ depends: [
   "dune" {>= "3.0"}
   "ocaml" {>= "4.08"}
   "odoc" {with-doc}
+  "yojson" {>= "2.0.0" & < "3.0.0"}
 ]
 dev-repo: "git+https://github.com/ocaml/ocaml-lsp.git"
 build: [

jsonrpc/src/dune

@@ -1,4 +1,5 @@
 (library
  (public_name jsonrpc)
+ (libraries yojson)
  (instrumentation
   (backend bisect_ppx)))

jsonrpc/src/import.ml

@@ -25,7 +25,7 @@ module Json = struct
   exception Of_json of (string * t)
 
   let () =
-    Printexc.register_printer (function
+    (Printexc.register_printer [@ocaml.alert "-unsafe_multidomain"]) (function
       | Of_json (msg, _) -> Some ("Jsonrpc: json conversion failed: " ^ msg)
       | _ -> None)
   ;;

jsonrpc/src/jsonrpc.ml

@@ -146,6 +146,23 @@ module Response = struct
         | Other code -> code
       ;;
 
+      let to_string = function
+        | ParseError -> "ParseError"
+        | InvalidRequest -> "InvalidRequest"
+        | MethodNotFound -> "MethodNotFound"
+        | InvalidParams -> "InvalidParams"
+        | InternalError -> "InternalError"
+        | ServerErrorStart -> "ServerErrorStart"
+        | ServerErrorEnd -> "ServerErrorEnd"
+        | ServerNotInitialized -> "ServerNotInitialized"
+        | UnknownErrorCode -> "UnknownErrorCode"
+        | RequestCancelled -> "RequestCancelled"
+        | ContentModified -> "ContentModified"
+        | ServerCancelled -> "ServerCancelled"
+        | RequestFailed -> "RequestFailed"
+        | Other _ -> "Other"
+      ;;
+
       let t_of_yojson json =
         match json with
         | `Int i -> of_int i
@@ -183,6 +200,24 @@ module Response = struct
 
     exception E of t
 
+    let () =
+      (Printexc.register_printer [@ocaml.alert "-unsafe_multidomain"]) (function
+        | E { code; message; data } ->
+          let data =
+            match data with
+            | None -> ""
+            | Some data -> "\n" ^ Yojson.Safe.pretty_to_string data
+          in
+          Some
+            (Printf.sprintf
+               "%s(%d): %s%s"
+               (Code.to_string code)
+               (Code.to_int code)
+               message
+               data)
+        | _ -> None)
+    ;;
+
     let raise t = raise (E t)
     let make ?data ~code ~message () = { data; code; message }
 
@@ -247,8 +282,8 @@ module Packet = struct
     | Batch_call r ->
       `List
         (List.map r ~f:(function
-           | `Request r -> Request.yojson_of_t r
-           | `Notification r -> Notification.yojson_of_t r))
+          | `Request r -> Request.yojson_of_t r
+          | `Notification r -> Notification.yojson_of_t r))
   ;;
 
   let t_of_fields (fields : (string * Json.t) list) =

lev-fiber-async/.fe.sexp

@@ -0,0 +1,5 @@
+(Scrutiny normal)
+(Owner ddickstein)
+(Reviewed_by (All_of (Users ddickstein troeder)))
+(Apply_to All_files)
+Used_in_subdirectory

lev-fiber-async/src/dune

@@ -0,0 +1,18 @@
+(library
+  (name lev_fiber_async)
+  (libraries
+    async
+    async_kernel
+    async_unix
+    base
+    core
+    core_unix
+    core_unix.signal_unix
+    csexp
+    fiber
+    fiber_async
+    ppx_expect
+    stdune
+    unix)
+  (preprocess
+    (pps ppx_jane)))