From 58ba73b5913bdacda17bfb1ca91a865bbb967847 Mon Sep 17 00:00:00 2001 From: Antonio Nuno Monteiro Date: Sun, 12 Jul 2026 18:32:27 -0700 Subject: [PATCH] feat(merlin): allow multiple configurations per file Signed-off-by: Antonio Nuno Monteiro --- src/dune_rules/exe_rules.ml | 1 + src/dune_rules/gen_rules.ml | 4 +- src/dune_rules/lib_rules.ml | 1 + src/dune_rules/melange/melange_rules.ml | 1 + src/dune_rules/merlin/merlin.ml | 223 +++++++++++++++--------- src/dune_rules/merlin/merlin.mli | 6 +- 6 files changed, 147 insertions(+), 89 deletions(-) diff --git a/src/dune_rules/exe_rules.ml b/src/dune_rules/exe_rules.ml index 3b9bfe8f6e9..a64af9b027f 100644 --- a/src/dune_rules/exe_rules.ml +++ b/src/dune_rules/exe_rules.ml @@ -361,6 +361,7 @@ let executables_rules ~dialects:(Dune_project.dialects (Scope.project scope)) ~ident:(Merlin_ident.for_exes ~names:(Nonempty_list.map ~f:snd exes.names)) ~for_ + ~is_default:true ~parameters:(Resolve.return []) in cctx, merlin diff --git a/src/dune_rules/gen_rules.ml b/src/dune_rules/gen_rules.ml index 340d5bad350..1d818b07d45 100644 --- a/src/dune_rules/gen_rules.ml +++ b/src/dune_rules/gen_rules.ml @@ -46,7 +46,7 @@ module For_stanza : sig -> scope:Scope.t -> dir_contents:Dir_contents.t -> expander:Expander.t - -> ( Merlin.t list + -> ( Merlin.group list , Compilation_context.t option Compilation_mode.Per_mode.t Loc.Map.t , Path.Build.t list , Path.Source.t list ) @@ -107,7 +107,7 @@ end = struct ;; let with_cctx_merlin ~loc (cctx, merlin) = - { empty_none with merlin = Some merlin; cctx = Some (loc, cctx) } + { empty_none with merlin = Some (Merlin.group [ merlin ]); cctx = Some (loc, cctx) } ;; let if_available_buildable ~loc f = function diff --git a/src/dune_rules/lib_rules.ml b/src/dune_rules/lib_rules.ml index 32315fcaaa8..3ddf9e7aac0 100644 --- a/src/dune_rules/lib_rules.ml +++ b/src/dune_rules/lib_rules.ml @@ -667,6 +667,7 @@ let library_rules ~dialects:(Dune_project.dialects (Scope.project scope)) ~ident:(Merlin_ident.for_lib (Library.best_name lib)) ~for_ + ~is_default:for_merlin ~parameters in merlin diff --git a/src/dune_rules/melange/melange_rules.ml b/src/dune_rules/melange/melange_rules.ml index 5ad92208b14..929f7a77671 100644 --- a/src/dune_rules/melange/melange_rules.ml +++ b/src/dune_rules/melange/melange_rules.ml @@ -619,6 +619,7 @@ let setup_emit_cmj_rules ~ident:merlin_ident ~dialects:(Dune_project.dialects (Scope.project scope)) ~for_ + ~is_default:true ~parameters:(Resolve.return []) ) in let* () = Buildable_rules.gen_select_rules sctx compile_info ~dir ~for_ in diff --git a/src/dune_rules/merlin/merlin.ml b/src/dune_rules/merlin/merlin.ml index 811e5d2a150..517938a78b4 100644 --- a/src/dune_rules/merlin/merlin.ml +++ b/src/dune_rules/merlin/merlin.ml @@ -117,12 +117,15 @@ module Processed = struct ;; (* ...but modules can have different preprocessing specifications*) - type t = + type configuration = { config : config ; per_file_config : module_config Path.Build.Map.t ; pp_config : pp_flag option Module_name.Per_item.t + ; is_default : bool } + type t = configuration Nonempty_list.t + type output_format = [ `Text | `Json @@ -154,9 +157,9 @@ module Processed = struct ;; end - let repr = + let configuration_repr = Repr.record - "merlin-processed" + "merlin-processed-configuration" [ Repr.field "config" config_repr ~get:(fun t -> t.config) ; Repr.field "per_file_config" @@ -166,9 +169,11 @@ module Processed = struct "pp_config" (Module_name.Per_item.repr (Repr.option pp_flag_repr)) ~get:(fun t -> t.pp_config) + ; Repr.field "is_default" Repr.bool ~get:(fun t -> t.is_default) ] ;; + let repr = Repr.view (Repr.list configuration_repr) ~to_:Nonempty_list.to_list let to_dyn = Repr.to_dyn repr module D = struct @@ -176,7 +181,7 @@ module Processed = struct let name = "merlin-conf" let sharing = false - let version = 8 + let version = 9 let repr = Repr.view Repr.string ~to_:(fun _ -> "Use [dune ocaml dump-dot-merlin] instead") @@ -376,7 +381,7 @@ module Processed = struct Buffer.contents b ;; - let get { per_file_config; pp_config; config } ~file = + let get_configuration { per_file_config; pp_config; config; is_default = _ } ~file = let open Option.O in let+ { module_; opens; reader } = let find file = Path.Build.Map.find per_file_config file in @@ -401,7 +406,23 @@ module Processed = struct to_sexp ~unit_name ~opens ~pp ~reader config ;; - let dump_entries { per_file_config; pp_config; config } : Dump_entry.t list = + let get configurations ~file = + let rec loop fallback = function + | [] -> fallback + | configuration :: configurations -> + (match get_configuration configuration ~file with + | None -> loop fallback configurations + | Some directives -> + if configuration.is_default + then Some directives + else loop (Option.first_some fallback (Some directives)) configurations) + in + loop None (Nonempty_list.to_list configurations) + ;; + + let dump_entries { per_file_config; pp_config; config; is_default = _ } + : Dump_entry.t list + = Path.Build.Map.to_list per_file_config |> List.map ~f:(fun (source_path, { module_; opens; reader }) -> let module_name = Module.name module_ in @@ -428,7 +449,10 @@ module Processed = struct let print_file path = match load_file path with | Error msg -> Printf.eprintf "%s\n" msg - | Ok t -> dump_entries t |> List.iter ~f:print_entry + | Ok configurations -> + Nonempty_list.to_list_map configurations ~f:dump_entries + |> List.concat + |> List.iter ~f:print_entry ;; let print_files format paths = @@ -439,7 +463,8 @@ module Processed = struct Result.List.map paths ~f:(fun path -> match load_file path with | Error msg -> Error msg - | Ok t -> Ok (dump_entries t)) + | Ok configurations -> + Ok (Nonempty_list.to_list_map configurations ~f:dump_entries |> List.concat)) with | Error msg -> Printf.eprintf "%s\n" msg | Ok entries -> @@ -452,78 +477,87 @@ module Processed = struct let print_generic_dot_merlin paths = match Result.List.map paths ~f:load_file with | Error msg -> Printf.eprintf "%s\n" msg - | Ok [] -> Printf.eprintf "No merlin configuration found.\n" - | Ok (init :: tl) -> - let ( pp_configs - , obj_dirs - , src_dirs - , hidden_obj_dirs - , hidden_src_dirs - , flags - , extensions - , indexes ) - = - (* We merge what is easy to merge and ignore the rest *) - List.fold_left - tl - ~init: - ( [ init.pp_config ] - , init.config.obj_dirs - , init.config.src_dirs - , init.config.hidden_obj_dirs - , init.config.hidden_src_dirs - , [ init.config.flags ] - , init.config.extensions - , init.config.indexes ) - ~f: - (fun - ( acc_pp - , acc_obj - , acc_src - , acc_hidden_obj - , acc_hidden_src - , acc_flags - , acc_ext - , acc_indexes ) - { per_file_config = _ - ; pp_config - ; config = - { stdlib_dir = _ - ; source_root = _ - ; obj_dirs - ; src_dirs - ; hidden_obj_dirs - ; hidden_src_dirs - ; flags - ; extensions - ; indexes - ; parameters = _ - } - } - -> - ( pp_config :: acc_pp - , Path.Set.union acc_obj obj_dirs - , Path.Set.union acc_src src_dirs - , Path.Set.union acc_hidden_obj hidden_obj_dirs - , Path.Set.union acc_hidden_src hidden_src_dirs - , flags :: acc_flags - , extensions @ acc_ext - , indexes @ acc_indexes )) + | Ok containers -> + let configurations = + List.map containers ~f:(fun configurations -> + List.find (Nonempty_list.to_list configurations) ~f:(fun configuration -> + configuration.is_default) + |> Option.value ~default:(Nonempty_list.hd configurations)) in - Printf.printf - "%s\n" - (to_dot_merlin - init.config.stdlib_dir - init.config.source_root - pp_configs - flags - obj_dirs - src_dirs - hidden_obj_dirs - hidden_src_dirs - extensions - indexes - init.config.parameters) + (match configurations with + | [] -> Printf.eprintf "No merlin configuration found.\n" + | init :: tl -> + let ( pp_configs + , obj_dirs + , src_dirs + , hidden_obj_dirs + , hidden_src_dirs + , flags + , extensions + , indexes ) + = + (* We merge what is easy to merge and ignore the rest *) + List.fold_left + tl + ~init: + ( [ init.pp_config ] + , init.config.obj_dirs + , init.config.src_dirs + , init.config.hidden_obj_dirs + , init.config.hidden_src_dirs + , [ init.config.flags ] + , init.config.extensions + , init.config.indexes ) + ~f: + (fun + ( acc_pp + , acc_obj + , acc_src + , acc_hidden_obj + , acc_hidden_src + , acc_flags + , acc_ext + , acc_indexes ) + { per_file_config = _ + ; pp_config + ; is_default = _ + ; config = + { stdlib_dir = _ + ; source_root = _ + ; obj_dirs + ; src_dirs + ; hidden_obj_dirs + ; hidden_src_dirs + ; flags + ; extensions + ; indexes + ; parameters = _ + } + } + -> + ( pp_config :: acc_pp + , Path.Set.union acc_obj obj_dirs + , Path.Set.union acc_src src_dirs + , Path.Set.union acc_hidden_obj hidden_obj_dirs + , Path.Set.union acc_hidden_src hidden_src_dirs + , flags :: acc_flags + , extensions @ acc_ext + , indexes @ acc_indexes )) + in + Printf.printf + "%s\n" + (to_dot_merlin + init.config.stdlib_dir + init.config.source_root + pp_configs + flags + obj_dirs + src_dirs + hidden_obj_dirs + hidden_src_dirs + extensions + indexes + init.config.parameters)) ;; end @@ -558,6 +592,7 @@ module Unprocessed = struct type t = { ident : Merlin_ident.t + ; is_default : bool ; config : config ; modules : Modules.With_vlib.t } @@ -574,6 +609,7 @@ module Unprocessed = struct ~dialects ~ident ~for_ + ~is_default ~parameters = (* Merlin shouldn't cause the build to fail, so we just ignore errors *) @@ -602,7 +638,7 @@ module Unprocessed = struct ; parameters } in - { ident; config; modules } + { ident; is_default; config; modules } ;; let encode_command = @@ -720,6 +756,7 @@ module Unprocessed = struct let process ({ modules ; ident = _ + ; is_default ; config = { stdlib_dir ; extensions @@ -833,19 +870,33 @@ module Unprocessed = struct (src, config) :: (src_without_extension, config) :: acc)) |> Path.Build.Map.of_list_reduce ~f:(fun existing _ -> existing) in - { Processed.pp_config; config; per_file_config } + { Processed.pp_config; config; per_file_config; is_default } ;; end -let dot_merlin sctx ~dir ~more_src_dirs ~expander (t : Unprocessed.t) = - let merlin_file = Merlin_ident.merlin_file_path dir t.ident in +type group = Unprocessed.t Nonempty_list.t + +let group configurations = configurations + +let dot_merlin sctx ~dir ~more_src_dirs ~expander (first :: rest : group) = + let merlin_file = Merlin_ident.merlin_file_path dir first.ident in let* () = Rules.Produce.Alias.add_deps (Alias.make Alias0.check ~dir) (Action_builder.path (Path.build merlin_file)) in + let configurations = + let open Action_builder.O in + let+ first = Unprocessed.process first sctx ~dir ~more_src_dirs ~expander + and+ rest = + List.map rest ~f:(fun configuration -> + Unprocessed.process configuration sctx ~dir ~more_src_dirs ~expander) + |> Action_builder.all + in + (first :: rest : Processed.t) + in let action = - Unprocessed.process t sctx ~dir ~more_src_dirs ~expander + configurations |> Action_builder.map ~f:Processed.Persist.to_string |> Action_builder.with_no_targets |> Action_builder.With_targets.write_file_dyn merlin_file @@ -853,10 +904,10 @@ let dot_merlin sctx ~dir ~more_src_dirs ~expander (t : Unprocessed.t) = Super_context.add_rule sctx ~dir action ;; -let add_rules sctx ~dir ~more_src_dirs ~expander merlin = +let add_rules sctx ~dir ~more_src_dirs ~expander group = Memo.when_ (Context.merlin (Super_context.context sctx)) - (fun () -> dot_merlin sctx ~more_src_dirs ~expander ~dir merlin) + (fun () -> dot_merlin sctx ~more_src_dirs ~expander ~dir group) ;; let more_src_dirs dir_contents ~source_dirs = diff --git a/src/dune_rules/merlin/merlin.mli b/src/dune_rules/merlin/merlin.mli index b6b661bfacc..55bc5872b14 100644 --- a/src/dune_rules/merlin/merlin.mli +++ b/src/dune_rules/merlin/merlin.mli @@ -59,12 +59,16 @@ val make -> dialects:Dialect.DB.t -> ident:Merlin_ident.t -> for_:Compilation_mode.t + -> is_default:bool -> parameters:Module_name.t list Resolve.t (** The `parameters` argument takes the list of parameters from the compilation context and stores it in the form of `["-parameter"; "P1"; "-parameter"; "P2"]` where P1 and P2 are the parameters. *) -> t +type group + +val group : t Nonempty_list.t -> group val more_src_dirs : Dir_contents.t -> source_dirs:Path.Source.t list -> Path.Source.t list (** Add rules for generating the merlin configuration of a specific stanza @@ -74,7 +78,7 @@ val add_rules -> dir:Path.Build.t -> more_src_dirs:Path.Source.t list -> expander:Expander.t - -> t + -> group -> unit Memo.t val pp_config