Support --context flag of dune ocaml-merlin

CHANGES.md

@@ -8,6 +8,8 @@
 
 - Support folding of `ifthenelse` expressions (#1031)
 
+- Add `getDuneContexts` method and `--context` flag (#1238)
+
 ## Fixes
 
 - Detect document kind by looking at merlin's `suffixes` config.

ocaml-lsp-server/bin/main.ml

@@ -5,13 +5,17 @@ let () =
   Printexc.record_backtrace true;
   let version = ref false in
   let read_dot_merlin = ref false in
+  let dune_context = ref None in
   let arg = Lsp.Cli.Arg.create () in
   let spec =
     [ ("--version", Arg.Set version, "print version")
     ; ( "--fallback-read-dot-merlin"
       , Arg.Set read_dot_merlin
       , "read Merlin config from .merlin files. The `dot-merlin-reader` \
          package must be installed" )
+    ; ( "--context"
+      , Arg.String (fun p -> dune_context := Some p)
+      , "set Dune context" )
     ]
     @ Cli.Arg.spec arg
   in
@@ -39,7 +43,10 @@ let () =
     let module Exn_with_backtrace = Stdune.Exn_with_backtrace in
     match
       Exn_with_backtrace.try_with
-        (Ocaml_lsp_server.run channel ~read_dot_merlin:!read_dot_merlin)
+        (Ocaml_lsp_server.run
+           channel
+           ~dune_context:!dune_context
+           ~read_dot_merlin:!read_dot_merlin)
     with
     | Ok () -> ()
     | Error exn ->

ocaml-lsp-server/docs/ocamllsp/duneContexts-spec.md

@@ -0,0 +1,26 @@
+# Dune Contexts Request
+
+Dune Contexts Request is sent from the client to the server to get the list
+of contexts available in the current Dune workspace.
+
+Warning: this custom request is meant to be consumed by `ocaml-vscode-platform` exclusively,
+it can be removed any time and should not be relied on.
+
+## Client capability
+
+nothing that should be noted
+
+## Server capability
+
+property name: `handleDuneContexts`
+property type: `boolean`
+
+## Request
+
+- method: `ocamllsp/getDuneContexts`
+- params: none
+
+## Response
+
+- result: String[]
+- error: code and message set in case an exception happens during the processing of the request.

ocaml-lsp-server/src/custom_requests/req_dune_contexts.ml

@@ -0,0 +1,49 @@
+open Import
+
+let capability = ("handleDuneContexts", `Bool true)
+
+let meth = "ocamllsp/duneContexts"
+
+let on_request () =
+  match Bin.which "dune" with
+  | None ->
+    Jsonrpc.Response.Error.raise
+      (Jsonrpc.Response.Error.make
+         ~code:InternalError
+         ~message:"dune binary not found"
+         ())
+  | Some dune -> (
+    let describe =
+      "DUNE_CONFIG__GLOBAL_LOCK=disabled " ^ Fpath.to_string dune
+      ^ " describe contexts"
+    in
+    let temp_file = Filename.temp_file "req_dune_contexts" ".txt" in
+    let command = Printf.sprintf "%s > %s" describe temp_file in
+    let error ~data =
+      Jsonrpc.Response.Error.raise
+        (Jsonrpc.Response.Error.make
+           ~code:InternalError
+           ~message:"Execution of `dune describe contexts` failed"
+           ~data
+           ())
+    in
+
+    try
+      let exit_status = Sys.command command in
+      if exit_status = 0 then (
+        let ic = open_in temp_file in
+        let rec read_lines acc =
+          try
+            let line = input_line ic in
+            read_lines (line :: acc)
+          with End_of_file -> List.rev acc
+        in
+        let lines = read_lines [] in
+        close_in ic;
+        Sys.remove temp_file;
+        Json.yojson_of_list (fun line -> `String line) lines)
+      else error ~data:(`Assoc [ ("exitStatus", `Int exit_status) ])
+    with
+    | Sys_error msg -> error ~data:(`Assoc [ ("systemError", `String msg) ])
+    | Failure msg -> error ~data:(`Assoc [ ("Failure", `String msg) ])
+    | _ -> error ~data:(`String "Unknown error"))

ocaml-lsp-server/src/custom_requests/req_dune_contexts.mli

@@ -0,0 +1,7 @@
+open Import
+
+val capability : string * Json.t
+
+val meth : string
+
+val on_request : unit -> Json.t

ocaml-lsp-server/src/merlin_config.ml

@@ -30,6 +30,8 @@ open Fiber.O
 module Std = Merlin_utils.Std
 module Misc = Merlin_utils.Misc
 
+let dune_context = ref None
+
 module List = struct
   include List
 
@@ -192,7 +194,17 @@ module Process = struct
       let stdout_r, stdout_w = Unix.pipe () in
       Unix.set_close_on_exec stdin_w;
       let pid =
-        let argv = [ prog; "ocaml-merlin"; "--no-print-directory" ] in
+        let argv =
+          match !dune_context with
+          | None -> [ prog; "ocaml-merlin"; "--no-print-directory" ]
+          | Some dune_context ->
+            [ prog
+            ; "ocaml-merlin"
+            ; "--no-print-directory"
+            ; "--context"
+            ; dune_context
+            ]
+        in
         Pid.of_int
           (Spawn.spawn
              ~cwd:(Path dir)
@@ -244,7 +256,7 @@ module Dot_protocol_io =
 let should_read_dot_merlin = ref false
 
 type db =
-  { running : (string, entry) Table.t
+  { running : (String.t, entry) Table.t
   ; pool : Fiber.Pool.t
   }
 
@@ -451,6 +463,7 @@ module DB = struct
   let get t uri = create t uri
 
   let create () =
+    Log.log ~section:"server" (fun () -> Log.msg "creating DB" []);
     { running = Table.create (module String) 0; pool = Fiber.Pool.create () }
 
   let run t = Fiber.Pool.run t.pool

ocaml-lsp-server/src/merlin_config.mli

@@ -6,6 +6,8 @@ type t
 
 val should_read_dot_merlin : bool ref
 
+val dune_context : string option ref
+
 val config : t -> Mconfig.t Fiber.t
 
 val destroy : t -> unit Fiber.t

ocaml-lsp-server/src/ocaml_lsp_server.ml

@@ -98,6 +98,7 @@ let initialize_info (client_capabilities : ClientCapabilities.t) :
               ; Req_wrapping_ast_node.capability
               ; Dune.view_promotion_capability
               ; Req_hover_extended.capability
+              ; Req_dune_contexts.capability
               ] )
         ]
     in
@@ -510,6 +511,10 @@ let on_request :
         , Semantic_highlighting.Debug.on_request_full )
       ; ( Req_hover_extended.meth
         , fun ~params _ -> Req_hover_extended.on_request ~params rpc )
+      ; ( Req_dune_contexts.meth
+        , fun ~params:_ _ ->
+            Fiber.of_thunk (fun () ->
+                Fiber.return (Req_dune_contexts.on_request ())) )
       ]
       |> List.assoc_opt meth
     with
@@ -931,10 +936,11 @@ let run_in_directory =
   let for_windows = !Merlin_utils.Std.System.run_in_directory in
   fun () -> if Sys.win32 then for_windows else run_in_directory
 
-let run channel ~read_dot_merlin () =
+let run channel ~dune_context ~read_dot_merlin () =
   Merlin_utils.Lib_config.set_program_name "ocamllsp";
   Merlin_utils.Lib_config.System.set_run_in_directory (run_in_directory ());
   Merlin_config.should_read_dot_merlin := read_dot_merlin;
+  Merlin_config.dune_context := Option.map dune_context ~f:Fun.id;
   Unix.putenv "__MERLIN_MASTER_PID" (string_of_int (Unix.getpid ()));
   Lev_fiber.run ~sigpipe:`Ignore (fun () ->
       let* input, output = stream_of_channel channel in

ocaml-lsp-server/src/ocaml_lsp_server.mli

@@ -1,4 +1,9 @@
-val run : Lsp.Cli.Channel.t -> read_dot_merlin:bool -> unit -> unit
+val run :
+     Lsp.Cli.Channel.t
+  -> dune_context:string option
+  -> read_dot_merlin:bool
+  -> unit
+  -> unit
 
 module Diagnostics = Diagnostics
 module Version = Version

ocaml-lsp-server/test/e2e-new/start_stop.ml

@@ -90,7 +90,8 @@ let%expect_test "start/stop" =
               "handleTypedHoles": true,
               "handleWrappingAstNode": true,
               "diagnostic_promotions": true,
-              "handleHoverExtended": true
+              "handleHoverExtended": true,
+              "handleDuneContexts": true
             }
           },
           "foldingRangeProvider": true,