merlin: add new contexts commands

bin/describe/describe.ml

@@ -19,6 +19,7 @@ let subcommands =
   ; Aliases_targets.Aliases_cmd.command
   ; Package_entries.command
   ; Describe_pkg.command
+  ; Describe_contexts.command
   ]
 ;;
 

bin/describe/describe_contexts.ml

@@ -0,0 +1,23 @@
+open Import
+
+let term =
+  let+ builder = Common.Builder.term in
+  let common, config = Common.init builder in
+  Scheduler.go ~common ~config
+  @@ fun () ->
+  let open Fiber.O in
+  let* setup = Import.Main.setup () in
+  let+ setup = Memo.run setup in
+  let ctxts =
+    List.map
+      ~f:(fun (name, _) -> Context_name.to_string name)
+      (Context_name.Map.to_list setup.scontexts)
+  in
+  List.iter ctxts ~f:print_endline
+;;
+
+let command =
+  let doc = "List the build contexts available in the workspace." in
+  let info = Cmd.info ~doc "contexts" in
+  Cmd.v info term
+;;

bin/describe/describe_contexts.mli

@@ -0,0 +1,4 @@
+open Import
+
+(** Dune command to print out the available build contexts.*)
+val command : unit Cmd.t

bin/ocaml/ocaml_merlin.ml

@@ -1,13 +1,34 @@
 open Import
 
+module Selected_context = struct
+  let arg =
+    let ctx_name_conv =
+      let parse ctx_name =
+        match Context_name.of_string_opt ctx_name with
+        | None -> Error (`Msg (Printf.sprintf "Invalid context name %S" ctx_name))
+        | Some ctx_name -> Ok ctx_name
+      in
+      let print ppf t = Stdlib.Format.fprintf ppf "%s" (Context_name.to_string t) in
+      Arg.conv ~docv:"context" (parse, print)
+    in
+    Arg.(
+      value
+      & opt ctx_name_conv Context_name.default
+      & info
+          [ "context" ]
+          ~docv:"CONTEXT"
+          ~doc:"Select the Dune build context that will be used to return information")
+  ;;
+end
+
 module Server : sig
-  val dump : string -> unit Fiber.t
-  val dump_dot_merlin : string -> unit Fiber.t
+  val dump : selected_context:Context_name.t -> string -> unit Fiber.t
+  val dump_dot_merlin : selected_context:Context_name.t -> string -> unit Fiber.t
 
   (** Once started the server will wait for commands on stdin, read the
       requested merlin dot file and return its content on stdout. The server
       will halt when receiving EOF of a bad csexp. *)
-  val start : unit -> unit Fiber.t
+  val start : selected_context:Context_name.t -> unit -> unit Fiber.t
 end = struct
   open Fiber.O
 
@@ -129,48 +150,53 @@ end = struct
       |> error
   ;;
 
-  let to_local file =
+  let to_local ~selected_context file =
     match to_local file with
     | Error s -> Fiber.return (Error s)
     | Ok file ->
-      let+ workspace = Memo.run (Workspace.workspace ()) in
-      let module Context_name = Dune_engine.Context_name in
-      (match workspace.merlin_context with
-       | None -> Error "no merlin context configured"
-       | Some context ->
-         Ok (Path.Build.append_local (Context_name.build_dir context) file))
+      (match Dune_engine.Context_name.is_default selected_context with
+       | false ->
+         Fiber.return
+           (Ok (Path.Build.append_local (Context_name.build_dir selected_context) file))
+       | true ->
+         let+ workspace = Memo.run (Workspace.workspace ()) in
+         (match workspace.merlin_context with
+          | None -> Error "no merlin context configured"
+          | Some context ->
+            Ok (Path.Build.append_local (Context_name.build_dir context) file)))
   ;;
 
-  let print_merlin_conf file =
-    to_local file
+  let print_merlin_conf ~selected_context file =
+    to_local ~selected_context file
     >>| (function
            | Error s -> Merlin_conf.make_error s
            | Ok file -> load_merlin_file file)
     >>| Merlin_conf.to_stdout
   ;;
 
-  let dump s =
-    to_local s
+  let dump ~selected_context s =
+    to_local ~selected_context s
     >>| function
     | Error mess -> Printf.eprintf "%s\n%!" mess
     | Ok path -> get_merlin_files_paths path |> List.iter ~f:Merlin.Processed.print_file
   ;;
 
-  let dump_dot_merlin s =
-    to_local s
+  let dump_dot_merlin ~selected_context s =
+    to_local ~selected_context s
     >>| function
     | Error mess -> Printf.eprintf "%s\n%!" mess
     | Ok path ->
       let files = get_merlin_files_paths path in
       Merlin.Processed.print_generic_dot_merlin files
   ;;
 
-  let start () =
+  let start ~selected_context () =
+    let open Fiber.O in
     let rec main () =
       match Commands.read_input stdin with
       | Halt -> Fiber.return ()
       | File path ->
-        let* () = print_merlin_conf path in
+        let* () = print_merlin_conf ~selected_context path in
         main ()
       | Unknown msg ->
         Merlin_conf.to_stdout (Merlin_conf.make_error msg);
@@ -192,15 +218,16 @@ module Dump_config = struct
 
   let term =
     let+ builder = Common.Builder.term
-    and+ dir = Arg.(value & pos 0 dir "" & info [] ~docv:"PATH") in
+    and+ dir = Arg.(value & pos 0 dir "" & info [] ~docv:"PATH")
+    and+ selected_context = Selected_context.arg in
     let common, config =
       let builder =
         let builder = Common.Builder.forbid_builds builder in
         Common.Builder.disable_log_file builder
       in
       Common.init builder
     in
-    Scheduler.go ~common ~config (fun () -> Server.dump dir)
+    Scheduler.go ~common ~config (fun () -> Server.dump ~selected_context dir)
   ;;
 
   let command = Cmd.v info term
@@ -222,15 +249,16 @@ let man =
 let start_session_info name = Cmd.info name ~doc ~man
 
 let start_session_term =
-  let+ builder = Common.Builder.term in
+  let+ builder = Common.Builder.term
+  and+ selected_context = Selected_context.arg in
   let common, config =
     let builder =
       let builder = Common.Builder.forbid_builds builder in
       Common.Builder.disable_log_file builder
     in
     Common.init builder
   in
-  Scheduler.go ~common ~config Server.start
+  Scheduler.go ~common ~config (Server.start ~selected_context)
 ;;
 
 let command = Cmd.v (start_session_info "ocaml-merlin") start_session_term
@@ -264,7 +292,7 @@ module Dump_dot_merlin = struct
             ~doc:
               "The path to the folder of which the configuration should be printed. \
                Defaults to the current directory.")
-    in
+    and+ selected_context = Selected_context.arg in
     let common, config =
       let builder =
         let builder = Common.Builder.forbid_builds builder in
@@ -274,8 +302,8 @@ module Dump_dot_merlin = struct
     in
     Scheduler.go ~common ~config (fun () ->
       match path with
-      | Some s -> Server.dump_dot_merlin s
-      | None -> Server.dump_dot_merlin ".")
+      | Some s -> Server.dump_dot_merlin ~selected_context s
+      | None -> Server.dump_dot_merlin ~selected_context ".")
   ;;
 
   let command = Cmd.v info term

doc/changes/10324.md

@@ -0,0 +1,5 @@
+- Add new flag `--context` to `dune ocaml-merlin`, which allows to select a Dune
+  context when requesting Merlin config. Add `dune describe contexts`
+  subcommand. Introduce a field `generate_merlin_rules` for contexts declared in
+  the workspace, that allows to optionally produce Merlin rules for other
+  contexts besides the one selected for Merlin (#10324, @jchavarri)

doc/reference/dune-workspace/context.rst

@@ -21,6 +21,9 @@ the description of an opam switch, as follows:
 
 - ``(merlin)`` instructs Dune to use this build context for Merlin.
 
+- ``(generate_merlin_rules)`` instructs Dune to generate Merlin rules for this
+  context, even if it is not the one selected via ``(merlin)``.
+
 - ``(profile <profile>)`` sets a different profile for a :term:`build context`. This has
   precedence over the command-line option ``--profile``.
 

src/dune_rules/context.ml

@@ -150,7 +150,10 @@ module Builder = struct
       extend_paths ~env paths
     in
     { t with
-      merlin
+      merlin =
+        (match merlin with
+         | Selected -> true
+         | Rules_only | Not_selected -> false)
     ; profile
     ; dynamically_linked_foreign_archives
     ; instrument_with
@@ -610,7 +613,13 @@ module Group = struct
         | Opam opam -> Builder.set_workspace_base builder opam.base
         | Default default ->
           let builder = Builder.set_workspace_base builder default.base in
-          let merlin = workspace.merlin_context = Some (Workspace.Context.name context) in
+          let merlin =
+            workspace.merlin_context = Some (Workspace.Context.name context)
+            ||
+            match default.base.merlin with
+            | Rules_only -> true
+            | Not_selected | Selected -> false
+          in
           { builder with merlin }
       in
       match context with

src/dune_rules/workspace.ml

@@ -266,6 +266,28 @@ module Context = struct
     ;;
   end
 
+  module Merlin = struct
+    type t =
+      | Selected
+      | Rules_only
+      | Not_selected
+
+    let equal x y =
+      match x, y with
+      | Selected, Selected | Rules_only, Rules_only | Not_selected, Not_selected -> true
+      | Selected, (Rules_only | Not_selected)
+      | (Rules_only | Not_selected), Selected
+      | Rules_only, Not_selected
+      | Not_selected, Rules_only -> false
+    ;;
+
+    let to_dyn : t -> Dyn.t = function
+      | Selected -> String "selected"
+      | Rules_only -> String "rules_only"
+      | Not_selected -> String "not_selected"
+    ;;
+  end
+
   module Common = struct
     type t =
       { loc : Loc.t
@@ -279,7 +301,7 @@ module Context = struct
       ; fdo_target_exe : Path.t option
       ; dynamically_linked_foreign_archives : bool
       ; instrument_with : Lib_name.t list
-      ; merlin : bool
+      ; merlin : Merlin.t
       }
 
     let to_dyn { name; targets; host_context; _ } =
@@ -318,7 +340,7 @@ module Context = struct
            dynamically_linked_foreign_archives
            t.dynamically_linked_foreign_archives
       && List.equal Lib_name.equal instrument_with t.instrument_with
-      && Bool.equal merlin t.merlin
+      && Merlin.equal merlin t.merlin
     ;;
 
     let fdo_suffix t =
@@ -384,7 +406,12 @@ module Context = struct
           "instrument_with"
           (Dune_lang.Syntax.since syntax (2, 7) >>> repeat Lib_name.decode)
       and+ loc = loc
-      and+ merlin = field_b "merlin" in
+      and+ merlin = field_b "merlin"
+      and+ generate_merlin_rules =
+        field_b
+          ~check:(Dune_lang.Syntax.since Stanza.syntax (3, 16))
+          "generate_merlin_rules"
+      in
       fun ~profile_default ~instrument_with_default ->
         let profile = Option.value profile ~default:profile_default in
         let instrument_with =
@@ -409,7 +436,13 @@ module Context = struct
         ; fdo_target_exe
         ; dynamically_linked_foreign_archives
         ; instrument_with
-        ; merlin
+        ; merlin =
+            (match merlin with
+             | true -> Selected
+             | false ->
+               (match generate_merlin_rules with
+                | true -> Rules_only
+                | false -> Not_selected))
         }
     ;;
   end
@@ -571,7 +604,7 @@ module Context = struct
           ; fdo_target_exe = None
           ; dynamically_linked_foreign_archives = true
           ; instrument_with = Option.value instrument_with ~default:[]
-          ; merlin = false
+          ; merlin = Not_selected
           }
       }
   ;;
@@ -840,11 +873,11 @@ let step1 clflags =
                 !defined_names
                 (Context_name.Set.of_list (Context.all_names ctx));
            match Context.base ctx, acc with
-           | { merlin = true; _ }, Some _ ->
+           | { merlin = Selected; _ }, Some _ ->
              User_error.raise
                ~loc:(Context.loc ctx)
                [ Pp.text "you can only have one context for merlin" ]
-           | { merlin = true; _ }, None -> Some name
+           | { merlin = Selected; _ }, None -> Some name
            | _ -> acc)
        in
        let contexts =

src/dune_rules/workspace.mli

@@ -38,6 +38,16 @@ module Context : sig
     val equal : t -> t -> bool
   end
 
+  module Merlin : sig
+    type t =
+      | Selected
+      | Rules_only
+      | Not_selected
+
+    val equal : t -> t -> bool
+    val to_dyn : t -> Dyn.t
+  end
+
   module Common : sig
     type t =
       { loc : Loc.t
@@ -57,7 +67,7 @@ module Context : sig
           the runtime system. *)
       ; dynamically_linked_foreign_archives : bool
       ; instrument_with : Lib_name.t list
-      ; merlin : bool
+      ; merlin : Merlin.t
       }
   end
 

test/blackbox-tests/test-cases/describe/describe-contexts.t

@@ -0,0 +1,19 @@
+Showcase behavior of the `dune describe contexts` subcommand
+
+  $ cat >dune-project <<EOF
+  > (lang dune 3.14)
+  > EOF
+
+  $ cat > dune-workspace << EOF
+  > (lang dune 3.14)
+  > 
+  > (context default)
+  > 
+  > (context
+  >  (default
+  >   (name alt)))
+  > EOF
+
+  $ dune describe contexts
+  alt
+  default