diff --git a/src/merlin.ml b/src/merlin.ml index 72c3314b..fb7c5ead 100644 --- a/src/merlin.ml +++ b/src/merlin.ml @@ -31,6 +31,37 @@ module Preprocess = struct | _ -> Other end +module Dot_file = struct + let b = Buffer.create 256 + + let printf = Printf.bprintf b + let print = Buffer.add_string b + + let to_string ~obj_dirs ~src_dirs ~flags ~ppx ~remaindir = + let serialize_path = Path.reach ~from:remaindir in + Buffer.clear b; + 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)); + begin match ppx with + | [] -> () + | ppx -> + printf "FLG -ppx %s\n" + (List.map ppx ~f:quote_for_shell + |> String.concat ~sep:" " + |> Filename.quote) + end; + begin match flags with + | [] -> () + | flags -> + print "FLG"; + List.iter flags ~f:(fun f -> printf " %s" (quote_for_shell f)); + print "\n" + end; + Buffer.contents b +end + type t = { requires : Lib.Set.t ; flags : (unit, string list) Build.t @@ -69,19 +100,15 @@ let ppx_flags sctx ~dir:_ ~scope ~src_dir:_ { preprocess; libname; _ } = match preprocess with | Pps { pps; flags } -> let exe = Preprocessing.get_ppx_driver sctx ~scope pps in - let command = - List.map (Path.to_absolute_filename exe ~root:!Clflags.workspace_root - :: "--as-ppx" - :: Preprocessing.cookie_library_name libname - @ flags) - ~f:quote_for_shell - |> String.concat ~sep:" " - in - [sprintf "FLG -ppx %s" (Filename.quote command)] + (Path.to_absolute_filename exe ~root:!Clflags.workspace_root + :: "--as-ppx" + :: Preprocessing.cookie_library_name libname + @ flags) | Other -> [] let dot_merlin sctx ~dir ~scope ({ requires; flags; _ } as t) = match Path.drop_build_context dir with + | None -> () | Some remaindir -> let merlin_file = Path.relative dir ".merlin" in (* We make the compilation of .ml/.mli files depend on the @@ -99,57 +126,22 @@ let dot_merlin sctx ~dir ~scope ({ requires; flags; _ } as t) = SC.add_rule sctx ~mode:Promote_but_delete_on_clean ( flags >>^ (fun flags -> - let ppx_flags = ppx_flags sctx ~dir ~scope ~src_dir:remaindir t in - let libs = - Lib.Set.fold requires ~init:[] ~f:(fun (lib : Lib.t) acc -> - let serialize_path = Path.reach ~from:remaindir in - let bpath = serialize_path (Lib.obj_dir lib) in - let spath = - Lib.src_dir lib - |> Path.drop_optional_build_context - |> serialize_path - in - ("B " ^ bpath) :: ("S " ^ spath) :: acc - ) + let (src_dirs, obj_dirs) = + Lib.Set.fold requires ~init:(Path.Set.empty, Path.Set.empty) + ~f:(fun (lib : Lib.t) (src_dirs, build_dirs) -> + ( Path.Set.add src_dirs (Lib.src_dir lib) + , Path.Set.add build_dirs ( + Lib.obj_dir lib + |> Path.drop_optional_build_context))) in - let source_dirs = - Path.Set.fold t.source_dirs ~init:[] ~f:(fun path acc -> - let path = Path.reach path ~from:remaindir in - ("S " ^ path)::acc - ) - in - let objs_dirs = - Path.Set.fold t.objs_dirs ~init:[] ~f:(fun path acc -> - let path = Path.reach path ~from:remaindir in - ("B " ^ path)::acc - ) - in - let flags = - match flags with - | [] -> [] - | _ -> - let escaped_flags = List.map ~f:quote_for_shell flags in - ["FLG " ^ String.concat escaped_flags ~sep:" "] - in - let dot_merlin = - List.concat - [ source_dirs - ; objs_dirs - ; libs - ; flags - ; ppx_flags - ] - in - dot_merlin - |> String.Set.of_list - |> String.Set.to_list - |> List.map ~f:(Printf.sprintf "%s\n") - |> String.concat ~sep:"") + Dot_file.to_string + ~remaindir + ~ppx:(ppx_flags sctx ~dir ~scope ~src_dir:remaindir t) + ~flags + ~src_dirs:(Path.Set.union src_dirs t.source_dirs) + ~obj_dirs:(Path.Set.union obj_dirs t.objs_dirs)) >>> - Build.write_file_dyn merlin_file - ) - | _ -> - () + Build.write_file_dyn merlin_file) let merge_two a b = { requires = Lib.Set.union a.requires b.requires diff --git a/test/blackbox-tests/test-cases/github759/run.t b/test/blackbox-tests/test-cases/github759/run.t index f1e17dd5..9f9f5bf2 100644 --- a/test/blackbox-tests/test-cases/github759/run.t +++ b/test/blackbox-tests/test-cases/github759/run.t @@ -1,17 +1,17 @@ $ jbuilder build foo.cma $ cat .merlin B _build/default/.foo.objs - FLG -open Foo -w -40 S . + FLG -open Foo -w -40 $ rm -f .merlin $ jbuilder build foo.cma $ cat .merlin B _build/default/.foo.objs - FLG -open Foo -w -40 S . + FLG -open Foo -w -40 $ echo toto > .merlin $ jbuilder build foo.cma $ cat .merlin B _build/default/.foo.objs - FLG -open Foo -w -40 S . + FLG -open Foo -w -40 diff --git a/test/blackbox-tests/test-cases/merlin-tests/run.t b/test/blackbox-tests/test-cases/merlin-tests/run.t index a55c2721..dce196b8 100644 --- a/test/blackbox-tests/test-cases/merlin-tests/run.t +++ b/test/blackbox-tests/test-cases/merlin-tests/run.t @@ -5,29 +5,29 @@ ocamlopt sanitize-dot-merlin/sanitize_dot_merlin.exe sanitize_dot_merlin alias print-merlins # Processing exe/.merlin - B ../_build/default/exe/.x.eobjs - B ../_build/default/lib/.foo.objs B $LIB_PREFIX/lib/bytes B $LIB_PREFIX/lib/findlib B $LIB_PREFIX/lib/ocaml - FLG -w -40 - S . - S ../lib + B ../_build/default/exe/.x.eobjs + B ../lib/.foo.objs S $LIB_PREFIX/lib/bytes S $LIB_PREFIX/lib/findlib S $LIB_PREFIX/lib/ocaml + S ../_build/default/lib + S . + FLG -w -40 # Processing lib/.merlin + B $LIB_PREFIX/lib/bytes + B $LIB_PREFIX/lib/findlib + B $LIB_PREFIX/lib/ocaml B ../_build/default/lib/.bar.objs B ../_build/default/lib/.foo.objs - B $LIB_PREFIX/lib/bytes - B $LIB_PREFIX/lib/findlib - B $LIB_PREFIX/lib/ocaml - FLG -open Foo -w -40 -open Bar -w -40 - FLG -ppx '$PPX/fooppx@./ppx.exe --as-ppx --cookie '\''library-name="foo"'\''' - S . S $LIB_PREFIX/lib/bytes S $LIB_PREFIX/lib/findlib S $LIB_PREFIX/lib/ocaml + S . + FLG -ppx '$PPX/fooppx@./ppx.exe --as-ppx --cookie '\''library-name="foo"'\''' + FLG -open Foo -w -40 -open Bar -w -40 Make sure a ppx directive is generated