[merlin] Add command to dump generic config in dot merlin syntax (#4250)

* Add merging and dot merlin printing to Merlin module * Add test illustrating the new behavior * Make `dump-dot-merlin` a sub command of the ocaml group * Make path optional for --dump-config * Add documentation for `dune ocaml-merlin` commands Signed-off-by: Ulysse Gérard <[email protected]>
ocaml · Feb 19, 2021 · 8f84cd1 · 8f84cd1
1 parent a4d9d20
commit 8f84cd1
Show file tree

Hide file tree

Showing 18 changed files with 227 additions and 31 deletions.
diff --git a/CHANGES.md b/CHANGES.md
@@ -56,6 +56,10 @@ Unreleased
 - Cleanup temporary files after running `$ dune exec`. (#4260, fixes #4243,
   @rgrinberg)
 
+- Add a new subcommand `dune ocaml dump-dot-merlin` that prints a mix of all the
+  merlin configuration of a directory (defaulting to the current directory) in
+  the Merlin configuration syntax. (#4250, @voodoos)
+
 2.8.2 (21/01/2021)
 ------------------
 

diff --git a/bin/ocaml.ml b/bin/ocaml.ml
@@ -6,6 +6,7 @@ let group =
   ( Term.Group.Group
       [ in_group Utop.command
       ; in_group Ocaml_merlin.command
+      ; in_group Ocaml_merlin.Dump_dot_merlin.command
       ; in_group Top.command
       ]
   , info )
diff --git a/bin/ocaml_merlin.ml b/bin/ocaml_merlin.ml
@@ -20,7 +20,7 @@ let term =
   and+ dump_config =
     Arg.(
       value
-      & opt (some string) None
+      & opt ~vopt:(Some ".") (some string) None
       & info [ "dump-config" ]
           ~doc:
             "Prints the entire content of the merlin configuration for the \
@@ -29,17 +29,57 @@ let term =
              ouptut.")
   in
   Common.set_common common ~log_file:No_log_file ~targets:[];
-  Scheduler.go ~common (fun () ->
-      Dune_engine.File_tree.init ~recognize_jbuilder_projects:true
-        ~ancestor_vcs:None;
-      let x = Common.x common in
-      let workspace_file =
-        Common.workspace_file common |> Option.map ~f:Arg.Path.path
-      in
-      Dune_rules.Workspace.init ?x ?workspace_file ();
-      ( match dump_config with
-      | Some s -> Dune_rules.Merlin_server.dump s
-      | None -> Dune_rules.Merlin_server.start () )
-      |> Fiber.return)
+  Dune_engine.File_tree.init ~recognize_jbuilder_projects:true
+    ~ancestor_vcs:None;
+  let x = Common.x common in
+  let workspace_file =
+    Common.workspace_file common |> Option.map ~f:Arg.Path.path
+  in
+  Dune_rules.Workspace.init ?x ?workspace_file ();
+  match dump_config with
+  | Some s -> Dune_rules.Merlin_server.dump s
+  | None -> Dune_rules.Merlin_server.start ()
 
 let command = (term, info)
+
+module Dump_dot_merlin = struct
+  let doc = "Print Merlin configuration"
+
+  let man =
+    [ `S "DESCRIPTION"
+    ; `P
+        {|$(b,dune ocaml dump-dot-merlin) will attempt to read previously
+        generated configuration in a source folder, merge them and print
+        it to the standard output in Merlin configuration syntax. The
+        output of this command should always be checked and adapted to
+        the project needs afterward.|}
+    ; Common.footer
+    ]
+
+  let info = Term.info "dump-dot-merlin" ~doc ~man
+
+  let term =
+    let+ common = Common.term
+    and+ path =
+      Arg.(
+        value
+        & pos 0 (some string) None
+        & info [] ~docv:"PATH"
+            ~doc:
+              "The path to the folder of which the configuration should be \
+               printed. Defaults to the current directory.")
+    in
+    Common.set_common common ~log_file:No_log_file ~targets:[];
+    Dune_engine.File_tree.init ~recognize_jbuilder_projects:true
+      ~ancestor_vcs:None;
+    let x = Common.x common in
+    let workspace_file =
+      Common.workspace_file common |> Option.map ~f:Arg.Path.path
+    in
+    Dune_rules.Workspace.init ?x ?workspace_file ();
+    match path with
+    | Some s -> Dune_rules.Merlin_server.dump_dot_merlin s
+    | None -> Dune_rules.Merlin_server.dump_dot_merlin "."
+
+  let command = (term, info)
+end
diff --git a/bin/ocaml_merlin.mli b/bin/ocaml_merlin.mli
@@ -1 +1,5 @@
 val command : unit Cmdliner.Term.t * Cmdliner.Term.info
+
+module Dump_dot_merlin : sig
+  val command : unit Cmdliner.Term.t * Cmdliner.Term.info
+end
diff --git a/doc/usage.rst b/doc/usage.rst
@@ -542,3 +542,51 @@ The `--prefix` directory should be used to specify the destination.
 If you are using plugins that depends on installed libraries which are not
 dependencies of the executables -- so libraries that need to be loaded at
 runtime -- you must copy the libraries manually to the destination directory.
+
+Querying Merlin configuration
+=============================
+
+Since version 2.8 Dune does not promote ``.merlin`` files to the source
+directories any more. Instead these configurations are stored in the `_build`
+folder and Merlin communicates directly with Dune to obtain its configuration
+via the `ocaml-merlin` subcommand. The Merlin configuration is now stanza
+specific allowing finer control. The following commands are not needed for
+normal use of Dune and Merlin but can provide insightful informations when
+debugging or configuring non-standard projects.
+
+Printing the configuration
+--------------------------
+
+It is possible to manually query the generated configuration for debugging
+purposes:
+
+::
+
+    $ dune ocaml-merlin --dump-config
+
+This command will print the distinct configuration of each module present in the
+current directory. This directory must be in a Dune workspace and the project
+must be already built. The configuration will be encoded as a s-expressions, which
+are used to communicate with Merlin.
+
+Printing an approximated ``.merlin``
+------------------------------------
+
+It is also possible to print the configuration of the current folder in the
+Merlin configuration syntax by running the following command:
+
+::
+
+    $ dune ocaml dump-dot-merlin > .merlin
+
+In that case only one configuration will be printed which is the result of a
+coarse merge of the configurations of the various modules present in the current
+folder. This folder must be in a Dune workspace and the project must be already
+built. Preprocessing directives and other flags will be commented out and must
+be un-commented afterward. This feature does not aim at writing exact or correct
+``.merlin`` files, its sole purpose is to lessen the burden of writing the
+configuration from scratch.
+
+Both these commands also support an optional path to specify the target
+directory. This directory must be in a Dune workspace and the project must have
+already been built.
diff --git a/src/dune_rules/merlin.ml b/src/dune_rules/merlin.ml
@@ -78,6 +78,50 @@ module Processed = struct
       (List.concat
          [ stdlib_dir; exclude_query_dir; obj_dirs; src_dirs; flags; suffixes ])
 
+  let quote_for_dot_merlin s =
+    let s =
+      if Sys.win32 then
+        (* We need this hack because merlin unescapes backslashes (except when
+           protected by single quotes). It is only a problem on windows because
+           Filename.quote is using double quotes. *)
+        String.escape_only '\\' s
+      else
+        s
+    in
+    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 serialize_path p = Path.to_absolute_filename p in
+    let b = Buffer.create 256 in
+    let printf = Printf.bprintf b in
+    let print = Buffer.add_string b in
+    Buffer.clear b;
+    print "EXCLUDE_QUERY_DIR\n";
+    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));
+    List.iter extensions ~f:(fun { Ml_kind.Dict.impl; intf } ->
+        printf "SUFFIX %s" (Printf.sprintf "%s %s" impl intf));
+
+    (* We print all FLG directives as comments *)
+    List.iter pp_configs
+      ~f:
+        (Module_name.Per_item.fold ~init:() ~f:(fun pp () ->
+             Option.iter pp ~f:(fun { flag; args } ->
+                 printf "# FLG %s\n" (flag ^ " " ^ quote_for_dot_merlin args))));
+
+    List.iter flags ~f:(fun flags ->
+        match flags with
+        | [] -> ()
+        | flags ->
+          print "# FLG";
+          List.iter flags ~f:(fun f -> printf " %s" (quote_for_dot_merlin f));
+          print "\n");
+    Buffer.contents b
+
   let get { modules; pp_config; config } ~filename =
     let fname = Filename.remove_extension filename |> String.lowercase in
     List.find_opt modules ~f:(fun name ->
@@ -101,6 +145,37 @@ module Processed = struct
         ++ Pp.newline
       in
       Format.printf "%a%!" Pp.to_fmt (Pp.concat_map modules ~f:pp_one)
+
+  let print_generic_dot_merlin paths =
+    let configs = List.filter_map paths ~f:load_file in
+    match configs with
+    | [] -> Printf.eprintf "No merlin config found"
+    | init :: tl ->
+      let pp_configs, obj_dirs, 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.flags ]
+            , init.config.extensions )
+          ~f:
+            (fun (acc_pp, acc_obj, acc_src, acc_flags, acc_ext)
+                 { modules = _
+                 ; pp_config
+                 ; config =
+                     { stdlib_dir = _; obj_dirs; src_dirs; flags; extensions }
+                 } ->
+            ( pp_config :: acc_pp
+            , Path.Set.union acc_obj obj_dirs
+            , Path.Set.union acc_src src_dirs
+            , flags :: acc_flags
+            , extensions @ acc_ext ))
+      in
+      Printf.printf "%s\n"
+        (to_dot_merlin init.config.stdlib_dir pp_configs flags obj_dirs src_dirs
+           extensions)
 end
 
 module Unprocessed = struct

diff --git a/src/dune_rules/merlin.mli b/src/dune_rules/merlin.mli
@@ -19,8 +19,14 @@ module Processed : sig
 
   val load_file : Path.t -> t option
 
+  (** [print_file path] reads the configuration at path [path] and print it as a
+      s-expression *)
   val print_file : Path.t -> unit
 
+  (** [print_generic_dot_merlin paths] will merge the given configurations and
+      print the resulting configuration in dot-merlin syntax. *)
+  val print_generic_dot_merlin : Path.t list -> unit
+
   val get : t -> filename:string -> Sexp.t option
 end
 

diff --git a/src/dune_rules/merlin_server.ml b/src/dune_rules/merlin_server.ml
@@ -132,6 +132,13 @@ let dump s =
     List.iter (get_merlin_files_paths path) ~f:Merlin.Processed.print_file
   | Error mess -> Printf.eprintf "%s\n%!" mess
 
+let dump_dot_merlin s =
+  match to_local s with
+  | Ok path ->
+    let files = get_merlin_files_paths path in
+    Merlin.Processed.print_generic_dot_merlin files
+  | Error mess -> Printf.eprintf "%s\n%!" mess
+
 let start () =
   let rec main () =
     match Commands.read_input stdin with

diff --git a/src/dune_rules/merlin_server.mli b/src/dune_rules/merlin_server.mli
@@ -3,6 +3,8 @@ open! Dune_engine
 
 val dump : string -> unit
 
+val dump_dot_merlin : string -> unit
+
 (** 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
     reiceving EOF of a bad csexp. *)

diff --git a/test/blackbox-tests/test-cases/merlin/dump-dot-merlin.t/dune-project b/test/blackbox-tests/test-cases/merlin/dump-dot-merlin.t/dune-project
@@ -0,0 +1 @@
+(lang dune 2.8)
diff --git a/test/blackbox-tests/test-cases/merlin/dump-dot-merlin.t/p p/dune b/test/blackbox-tests/test-cases/merlin/dump-dot-merlin.t/p p/dune
@@ -0,0 +1,2 @@
+(executable
+ (name pp))
diff --git a/test/blackbox-tests/test-cases/merlin/dump-dot-merlin.t/p p/pp.ml b/test/blackbox-tests/test-cases/merlin/dump-dot-merlin.t/p p/pp.ml
diff --git a/test/blackbox-tests/test-cases/merlin/dump-dot-merlin.t/run.t b/test/blackbox-tests/test-cases/merlin/dump-dot-merlin.t/run.t
@@ -0,0 +1,18 @@
+  $ dune build
+  $ dune ocaml dump-dot-merlin src\ with\ spaces |
+  > sed 's#'$(opam config var prefix)'#OPAM_PREFIX#'
+  EXCLUDE_QUERY_DIR
+  STDLIB OPAM_PREFIX/lib/ocaml
+  B $TESTCASE_ROOT/_build/default/src with spaces/.foo.eobjs/byte
+  S $TESTCASE_ROOT/src with spaces
+  # FLG -pp ''\''$TESTCASE_ROOT/_build/default/p p/pp.exe'\'''
+  # FLG -open Dune__exe -w @[email protected]@30..39@[email protected]@[email protected] -strict-sequence -strict-formats -short-paths -keep-locs
+  
+  $ dune ocaml dump-dot-merlin "p p" |
+  > sed 's#'$(opam config var prefix)'#OPAM_PREFIX#'
+  EXCLUDE_QUERY_DIR
+  STDLIB OPAM_PREFIX/lib/ocaml
+  B $TESTCASE_ROOT/_build/default/p p/.pp.eobjs/byte
+  S $TESTCASE_ROOT/p p
+  # FLG -w @[email protected]@30..39@[email protected]@[email protected] -strict-sequence -strict-formats -short-paths -keep-locs
+  
diff --git a/test/blackbox-tests/test-cases/merlin/dump-dot-merlin.t/src with spaces/bar.ml b/test/blackbox-tests/test-cases/merlin/dump-dot-merlin.t/src with spaces/bar.ml
diff --git a/test/blackbox-tests/test-cases/merlin/dump-dot-merlin.t/src with spaces/dune b/test/blackbox-tests/test-cases/merlin/dump-dot-merlin.t/src with spaces/dune
@@ -0,0 +1,3 @@
+(executables (names foo bar)
+ (preprocess (per_module
+  ((action (run "p p/pp.exe"%{input-file})) bar))))
diff --git a/test/blackbox-tests/test-cases/merlin/dump-dot-merlin.t/src with spaces/foo.ml b/test/blackbox-tests/test-cases/merlin/dump-dot-merlin.t/src with spaces/foo.ml
diff --git a/test/blackbox-tests/test-cases/merlin/symlinks.t/run.t b/test/blackbox-tests/test-cases/merlin/symlinks.t/run.t
@@ -28,6 +28,5 @@ Dune ocaml-merlin also accepts paths relative to the current directory
   $ dune ocaml-merlin --dump-config="." --root=".." |
   > sed 's#'$(opam config var prefix)'#OPAM_PREFIX#' |
   > head -n 2
-  Entering directory '..'
   Foo
   ((STDLIB OPAM_PREFIX/lib/ocaml)
diff --git a/test/blackbox-tests/test-cases/merlin/unit-names-merlin-gh1233.t/run.t b/test/blackbox-tests/test-cases/merlin/unit-names-merlin-gh1233.t/run.t
@@ -58,20 +58,6 @@
      -keep-locs)))
 
 FIXME : module Foo is not unbound
-  $ ocamlmerlin single errors -filename foo.ml < foo.ml | jq ".value"
-  [
-    {
-      "start": {
-        "line": 1,
-        "col": 10
-      },
-      "end": {
-        "line": 1,
-        "col": 25
-      },
-      "type": "typer",
-      "sub": [],
-      "valid": true,
-      "message": "Unbound module Foo"
-    }
-  ]
+This test is disabled because it depends on root detection and is not reproducible.
+$ ocamlmerlin single errors -filename foo.ml < foo.ml | jq ".value.message"
+"Unbound module Foo"