Skip to content

Commit

Permalink
Add all dependency source dirs to Merlin's configuration.
Browse files Browse the repository at this point in the history
Use new BH / SH directives

Signed-off-by: Ulysse Gérard <thevoodoos@gmail.com>
  • Loading branch information
voodoos committed May 15, 2024
1 parent bba5be3 commit 8dea06e
Show file tree
Hide file tree
Showing 7 changed files with 146 additions and 24 deletions.
4 changes: 3 additions & 1 deletion src/dune_rules/exe_rules.ml
Original file line number Diff line number Diff line change
Expand Up @@ -182,6 +182,7 @@ let executables_rules
let lib_config = ocaml.lib_config in
let stdlib_dir = lib_config.stdlib_dir in
let* requires_compile = Compilation_context.requires_compile cctx in
let* requires_link = Compilation_context.requires_link cctx in
let* dep_graphs =
(* Building an archive for foreign stubs, we link the corresponding object
files directly to improve perf. *)
Expand Down Expand Up @@ -265,7 +266,8 @@ let executables_rules
in
( cctx
, Merlin.make
~requires:requires_compile
~requires_compile
~requires_link
~stdlib_dir
~flags
~modules
Expand Down
4 changes: 3 additions & 1 deletion src/dune_rules/lib_rules.ml
Original file line number Diff line number Diff line change
Expand Up @@ -579,6 +579,7 @@ let library_rules
let scope = Compilation_context.scope cctx in
let* requires_compile = Compilation_context.requires_compile cctx in
let ocaml = Compilation_context.ocaml cctx in
let* requires_link = Compilation_context.requires_link cctx in
let stdlib_dir = ocaml.lib_config.stdlib_dir in
let top_sorted_modules =
let impl_only = Modules.With_vlib.impl_only modules in
Expand Down Expand Up @@ -631,7 +632,8 @@ let library_rules
in
( cctx
, Merlin.make
~requires:requires_compile
~requires_compile
~requires_link
~stdlib_dir
~flags
~modules
Expand Down
4 changes: 3 additions & 1 deletion src/dune_rules/melange/melange_rules.ml
Original file line number Diff line number Diff line change
Expand Up @@ -326,6 +326,7 @@ let setup_emit_cmj_rules
in
let* () = Module_compilation.build_all cctx in
let* requires_compile = Compilation_context.requires_compile cctx in
let* requires_link = Compilation_context.requires_link cctx in
let stdlib_dir = (Compilation_context.ocaml cctx).lib_config.stdlib_dir in
let+ () =
let emit_and_libs_deps =
Expand Down Expand Up @@ -354,7 +355,8 @@ let setup_emit_cmj_rules
in
( cctx
, Merlin.make
~requires:requires_compile
~requires_compile
~requires_link
~stdlib_dir
~flags
~modules
Expand Down
145 changes: 130 additions & 15 deletions src/dune_rules/merlin/merlin.ml
Original file line number Diff line number Diff line change
Expand Up @@ -50,16 +50,29 @@ module Processed = struct
{ stdlib_dir : Path.t option
; obj_dirs : Path.Set.t
; src_dirs : Path.Set.t
; hidden_obj_dirs : Path.Set.t
; hidden_src_dirs : Path.Set.t
; flags : string list
; extensions : string option Ml_kind.Dict.t list
}

let dyn_of_config { stdlib_dir; obj_dirs; src_dirs; flags; extensions } =
let dyn_of_config
{ stdlib_dir
; obj_dirs
; src_dirs
; hidden_obj_dirs
; hidden_src_dirs
; flags
; extensions
}
=
let open Dyn in
record
[ "stdlib_dir", option Path.to_dyn stdlib_dir
; "obj_dirs", Path.Set.to_dyn obj_dirs
; "src_dirs", Path.Set.to_dyn src_dirs
; "hidden_obj_dirs", Path.Set.to_dyn hidden_obj_dirs
; "hidden_src_dirs", Path.Set.to_dyn hidden_src_dirs
; "flags", list string flags
; "extensions", list (Ml_kind.Dict.to_dyn (Dyn.option string)) extensions
]
Expand Down Expand Up @@ -100,14 +113,16 @@ module Processed = struct
type nonrec t = t

let name = "merlin-conf"
let version = 4
let version = 5
let to_dyn _ = Dyn.String "Use [dune ocaml dump-dot-merlin] instead"

let test_example () =
{ config =
{ stdlib_dir = None
; obj_dirs = Path.Set.empty
; src_dirs = Path.Set.empty
; hidden_obj_dirs = Path.Set.empty
; hidden_src_dirs = Path.Set.empty
; flags = [ "-x" ]
; extensions = [ { Ml_kind.Dict.intf = None; impl = Some "ext" } ]
}
Expand Down Expand Up @@ -149,7 +164,19 @@ module Processed = struct
| None, None -> None
;;

let to_sexp ~opens ~pp ~reader { stdlib_dir; obj_dirs; src_dirs; flags; extensions } =
let to_sexp
~opens
~pp
~reader
{ stdlib_dir
; obj_dirs
; src_dirs
; hidden_obj_dirs
; hidden_src_dirs
; flags
; extensions
}
=
let make_directive tag value = Sexp.List [ Atom tag; value ] in
let make_directive_of_path tag path =
make_directive tag (Sexp.Atom (serialize_path path))
Expand All @@ -162,6 +189,12 @@ module Processed = struct
let exclude_query_dir = [ Sexp.List [ Atom "EXCLUDE_QUERY_DIR" ] ] in
let obj_dirs = Path.Set.to_list_map obj_dirs ~f:(make_directive_of_path "B") in
let src_dirs = Path.Set.to_list_map src_dirs ~f:(make_directive_of_path "S") in
let hidden_obj_dirs =
Path.Set.to_list_map hidden_obj_dirs ~f:(make_directive_of_path "BH")
in
let hidden_src_dirs =
Path.Set.to_list_map hidden_src_dirs ~f:(make_directive_of_path "SH")
in
let flags =
let flags =
match flags with
Expand Down Expand Up @@ -199,7 +232,16 @@ module Processed = struct
in
Sexp.List
(List.concat
[ stdlib_dir; exclude_query_dir; obj_dirs; src_dirs; flags; suffixes; reader ])
[ stdlib_dir
; exclude_query_dir
; obj_dirs
; src_dirs
; hidden_obj_dirs
; hidden_src_dirs
; flags
; suffixes
; reader
])
;;

let quote_for_dot_merlin s =
Expand All @@ -215,7 +257,16 @@ module Processed = struct
if String.need_quoting s then Filename.quote s else s
;;

let to_dot_merlin stdlib_dir pp_configs flags obj_dirs src_dirs extensions =
let to_dot_merlin
stdlib_dir
pp_configs
flags
obj_dirs
src_dirs
hidden_obj_dirs
hidden_src_dirs
extensions
=
let b = Buffer.create 256 in
let printf = Printf.bprintf b in
let print = Buffer.add_string b in
Expand All @@ -224,6 +275,8 @@ module Processed = struct
printf "STDLIB %s\n" (serialize_path stdlib_dir));
Path.Set.iter obj_dirs ~f:(fun p -> printf "B %s\n" (serialize_path p));
Path.Set.iter src_dirs ~f:(fun p -> printf "S %s\n" (serialize_path p));
Path.Set.iter hidden_obj_dirs ~f:(fun p -> printf "BH %s\n" (serialize_path p));
Path.Set.iter hidden_src_dirs ~f:(fun p -> printf "SH %s\n" (serialize_path p));
List.iter extensions ~f:(fun x ->
Option.iter (get_ext x) ~f:(fun (impl, intf) ->
printf "SUFFIX %s" (Printf.sprintf "%s %s" impl intf)));
Expand Down Expand Up @@ -295,27 +348,52 @@ module Processed = struct
| 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, flags, extensions =
let ( pp_configs
, obj_dirs
, src_dirs
, hidden_obj_dirs
, hidden_src_dirs
, flags
, extensions )
=
(* 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 )
~f:
(fun
(acc_pp, acc_obj, acc_src, acc_flags, acc_ext)
( acc_pp
, acc_obj
, acc_src
, acc_hidden_obj
, acc_hidden_src
, acc_flags
, acc_ext )
{ per_file_config = _
; pp_config
; config = { stdlib_dir = _; obj_dirs; src_dirs; flags; extensions }
; config =
{ stdlib_dir = _
; obj_dirs
; src_dirs
; hidden_obj_dirs
; hidden_src_dirs
; flags
; extensions
}
}
->
( 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 ))
in
Expand All @@ -327,6 +405,8 @@ module Processed = struct
flags
obj_dirs
src_dirs
hidden_obj_dirs
hidden_src_dirs
extensions)
;;
end
Expand All @@ -348,6 +428,7 @@ module Unprocessed = struct
type config =
{ stdlib_dir : Path.t
; requires : Lib.Set.t
; requires_hidden : Lib.Set.t
; flags : string list Action_builder.t
; preprocess :
Preprocess.Without_instrumentation.t Preprocess.t Module_name.Per_item.t
Expand All @@ -366,7 +447,8 @@ module Unprocessed = struct
}

let make
~requires
~requires_compile
~requires_link
~stdlib_dir
~flags
~preprocess
Expand All @@ -386,10 +468,19 @@ module Unprocessed = struct
| `Lib (m : Lib_mode.Map.Set.t) -> Lib_mode.Map.Set.for_merlin m
in
let requires =
match Resolve.peek requires with
match Resolve.peek requires_compile with
| Ok l -> Lib.Set.of_list l
| Error () -> Lib.Set.empty
in
let requires_link =
match Resolve.peek requires_link with
| Ok l -> Lib.Set.of_list l
| Error () -> Lib.Set.empty
in
let requires_hidden =
Lib.Set.filter requires_link ~f:(fun l ->
not (Lib.Set.exists requires ~f:(Lib.equal l)))
in
let objs_dirs =
Path.Set.singleton @@ obj_dir_of_lib `Private mode (Obj_dir.of_local obj_dir)
in
Expand All @@ -399,6 +490,7 @@ module Unprocessed = struct
{ stdlib_dir
; mode
; requires
; requires_hidden
; flags
; preprocess
; libname
Expand Down Expand Up @@ -515,6 +607,7 @@ module Unprocessed = struct
; objs_dirs
; source_dirs
; requires
; requires_hidden
; preprocess = _
; libname = _
; mode
Expand All @@ -539,9 +632,9 @@ module Unprocessed = struct
| [] -> None
| stdlib_dir :: _ -> Some stdlib_dir)
in
let* requires =
let* requires, requires_hidden =
match t.config.mode with
| Ocaml _ -> Action_builder.return requires
| Ocaml _ -> Action_builder.return (requires, requires_hidden)
| Melange ->
Action_builder.of_memo
(let open Memo.O in
Expand All @@ -560,8 +653,8 @@ module Unprocessed = struct
| Ok libs -> libs
| Error _ -> []
in
Lib.Set.union requires (Lib.Set.of_list libs)
| None -> Memo.return requires)
Lib.Set.union requires (Lib.Set.of_list libs), requires_hidden
| None -> Memo.return (requires, requires_hidden))
in
let+ flags = flags
and+ src_dirs, obj_dirs =
Expand All @@ -579,11 +672,33 @@ module Unprocessed = struct
obj_dir_of_lib `Public mode (Lib_info.obj_dir info)
in
Path.Set.add obj_dirs public_cmi_dir )))
and+ hidden_src_dirs, hidden_obj_dirs =
Action_builder.of_memo
(let open Memo.O in
Memo.parallel_map (Lib.Set.to_list requires_hidden) ~f:(fun lib ->
let+ dirs = src_dirs sctx lib in
lib, dirs)
>>| List.fold_left
~init:(Path.Set.empty, Path.Set.empty)
~f:(fun (src_dirs, obj_dirs) (lib, more_src_dirs) ->
( Path.Set.union src_dirs more_src_dirs
, let public_cmi_dir =
let info = Lib.info lib in
obj_dir_of_lib `Public mode (Lib_info.obj_dir info)
in
Path.Set.add obj_dirs public_cmi_dir )))
in
let src_dirs =
Path.Set.union src_dirs (Path.Set.of_list_map ~f:Path.source more_src_dirs)
in
{ Processed.stdlib_dir; src_dirs; obj_dirs; flags; extensions }
{ Processed.stdlib_dir
; src_dirs
; obj_dirs
; hidden_src_dirs
; hidden_obj_dirs
; flags
; extensions
}
and+ pp_config = pp_config t (Super_context.context sctx) ~expander in
let per_file_config =
(* And copy for each module the resulting pp flags *)
Expand Down
3 changes: 2 additions & 1 deletion src/dune_rules/merlin/merlin.mli
Original file line number Diff line number Diff line change
Expand Up @@ -41,7 +41,8 @@ module Processed : sig
end

val make
: requires:Lib.t list Resolve.t
: requires_compile:Lib.t list Resolve.t
-> requires_link:Lib.t list Resolve.t
-> stdlib_dir:Path.t
-> flags:Ocaml_flags.t
-> preprocess:Preprocess.Without_instrumentation.t Preprocess.t Module_name.Per_item.t
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -3,7 +3,7 @@

$ dune build @check

FIXME: Merlin must be able to locate the definitions of values coming from an
Merlin must be able to locate the definitions of values coming from an
implicit transitive dependency, even when `implicit-transitive-dependency` is
set to `false`. They should be part of the source path returned by the
configuration.
Expand All @@ -18,6 +18,8 @@ main -> lib1 -> lib2 -> stdlib
?:B?:$TESTCASE_ROOT/_build/default/src/lib1/.lib1.objs/byte)
?:S?:$TESTCASE_ROOT/bin)
?:S?:$TESTCASE_ROOT/src/lib1)
?:BH?:$TESTCASE_ROOT/_build/default/src/lib2/.lib2.objs/byte)
?:SH?:$TESTCASE_ROOT/src/lib2)

$ FILE=$PWD/src/lib1/lib1.ml
$ printf "(4:File%d:%s)" ${#FILE} $FILE | dune ocaml-merlin |
Expand All @@ -30,7 +32,5 @@ main -> lib1 -> lib2 -> stdlib
$ FILE=$PWD/src/lib2/lib2.ml
$ printf "(4:File%d:%s)" ${#FILE} $FILE | dune ocaml-merlin |
> sed -E "s/[[:digit:]]+:/\?:/g" | tr '(' '\n' | grep -E ":[BS]H?\?"
?:B?:/STDLIB)
?:B?:$TESTCASE_ROOT/_build/default/src/lib2/.lib2.objs/byte)
?:S?:/STDLIB)
?:S?:$TESTCASE_ROOT/src/lib2)
Loading

0 comments on commit 8dea06e

Please sign in to comment.