Allow selection of Dune context

CHANGELOG.md

@@ -2,6 +2,8 @@
 
 # Unreleased
 
+- Allow selection of Dune context (#1449)
+
 ## 1.18.1
 
 - Fix `sideEffects` field in `astexplorer/package.json` (#1427)

README.md

@@ -262,6 +262,7 @@ prefix `OCaml:`:
 | `ocaml.switch-impl-intf`     | Switch implementation/interface             | `Alt+O`            |
 | `ocaml.open-repl`            | Open REPL                                   |                    |
 | `ocaml.evaluate-selection`   | Evaluate Selection                          | `Shift+Enter`      |
+| `ocaml.select-dune-context`  | Select a Dune context for this workspace    |                    |
 
 ## Debugging OCaml programs (experimental)
 

package.json

@@ -241,6 +241,11 @@
         "command": "ocaml.goto-closure-code-location",
         "category": "OCaml",
         "title": "Goto Closure Code Location"
+      },
+      {
+        "command": "ocaml.select-dune-context",
+        "category": "OCaml",
+        "title": "Select a Dune context for this Workspace"
       }
     ],
     "configuration": {
@@ -290,6 +295,11 @@
           "default": true,
           "description": "Controls whether dune tasks should be automatically detected."
         },
+        "ocaml.dune.context": {
+          "type": "string",
+          "default": "default",
+          "markdownDescription": "Set the current Dune context for Merlin"
+        },
         "ocaml.trace.server": {
           "description": "Controls the logging output of the language server. Valid settings are `off`, `messages`, or `verbose`.",
           "type": "string",

src/extension_commands.ml

@@ -158,6 +158,80 @@ let ( _open_ocamllsp_output_pane
       Extension_consts.Commands.open_ocaml_commands_output
       (handler Output.command_output_channel) )
 
+let _set_dune_context =
+  let handler (instance : Extension_instance.t) ~args:_ =
+    let open Promise.Syntax in
+    let select_context (choices : string list) =
+      let current_context =
+        Option.value
+          ~default:"default"
+          (Settings.get Settings.dune_context_setting)
+      in
+      let choices =
+        let to_quick_pick current_context context =
+          let create = QuickPickItem.create in
+          let description =
+            if String.equal current_context context then
+              Some "Currently selected Dune context"
+            else None
+          in
+          create ~label:context ?description ()
+        in
+        List.map
+          ~f:(fun (context : string) ->
+            let quick_pick = to_quick_pick current_context context in
+            (quick_pick, context))
+          choices
+      in
+      let options =
+        let placeHolder =
+          "Which Dune context would you like to use in the editor?"
+        in
+        QuickPickOptions.create ~canPickMany:false ~placeHolder ()
+      in
+      Window.showQuickPickItems ~choices ~options ()
+    in
+    let select_dune_context () =
+      match Workspace.rootPath () with
+      | None ->
+        (* Assumes that Dune root matches the workspace root *)
+        Promise.return
+          (show_message
+             `Warn
+             "Project root wasn't found. Can't select Dune context without \
+              project root.")
+      | Some root -> (
+        let* result =
+          let sandbox = Extension_instance.sandbox instance in
+          let cmd =
+            Sandbox.get_command sandbox "dune" [ "describe"; "contexts" ]
+          in
+          let env =
+            Interop.Dict.of_alist [ ("DUNE_CONFIG__GLOBAL_LOCK", "disabled") ]
+          in
+          Cmd.output ~env ~cwd:(Path.of_string root) cmd
+        in
+        match result with
+        | Error msg ->
+          Promise.return
+            (show_message
+               `Warn
+               "Error when calling `dune describe contexts': %s"
+               msg)
+        | Ok output -> (
+          let candidates = String.split output ~on:'\n' in
+          let* context = select_context candidates in
+          match context with
+          | None (* context selection cancelled *) -> Promise.return ()
+          | Some new_context ->
+            let* () = Settings.set Settings.dune_context_setting new_context in
+            Extension_instance.start_language_server instance))
+    in
+    let (_ : unit Promise.t) = select_dune_context () in
+    ()
+  in
+  command Extension_consts.Commands.select_dune_context handler
+
 module Holes_commands : sig
   val _jump_to_prev_hole : t
 

src/extension_consts.ml

@@ -66,6 +66,8 @@ module Commands = struct
   let goto_closure_code_location = ocaml_prefixed "goto-closure-code-location"
 
   let ask_debug_program = ocaml_prefixed "ask-debug-program"
+
+  let select_dune_context = ocaml_prefixed "select-dune-context"
 end
 
 module Command_errors = struct

src/extension_instance.ml

@@ -112,6 +112,12 @@ end = struct
 
   let server_options sandbox =
     let args = Settings.(get server_args_setting) |> Option.value ~default:[] in
+    let args =
+      match Settings.get Settings.dune_context_setting with
+      | None -> args
+      | Some context -> "--context" :: context :: args
+    in
+
     let command = Sandbox.get_command sandbox "ocamllsp" args in
     Cmd.log command;
     let env =

src/settings.ml

@@ -141,3 +141,10 @@ let server_syntaxDocumentation_setting =
     ~key:"ocaml.server.syntaxDocumentation"
     ~of_json:Jsonoo.Decode.bool
     ~to_json:Jsonoo.Encode.bool
+
+let dune_context_setting =
+  create_setting
+    ~scope:ConfigurationTarget.Workspace
+    ~key:"ocaml.dune.context"
+    ~of_json:Jsonoo.Decode.string
+    ~to_json:Jsonoo.Encode.string

src/settings.mli

@@ -45,3 +45,5 @@ val server_extendedHover_setting : bool setting
 val server_duneDiagnostics_setting : bool setting
 
 val server_syntaxDocumentation_setting : bool setting
+
+val dune_context_setting : string setting