diff --git a/.github/workflows/binaries.yml b/.github/workflows/binaries.yml new file mode 100644 index 00000000000..a0d05dde240 --- /dev/null +++ b/.github/workflows/binaries.yml @@ -0,0 +1,40 @@ +name: Binaries + +on: + workflow_dispatch: + +jobs: + binary: + name: Create + strategy: + fail-fast: false + matrix: + include: + - os: macos-13 + name: mac-intel + installable: .# + - os: macos-14 + name: mac-arm + installable: .# + - os: ubuntu-22.04 + name: linux-intel + installable: .# + - os: ubuntu-22.04 + name: linux-intel-static + installable: .#dune-static + runs-on: ${{ matrix.os }} + steps: + - uses: actions/checkout@v4 + - uses: cachix/install-nix-action@v22 + - run: nix build ${{ installable }} + - uses: actions/upload-artifact@v4 + with: + path: result/bin/dune + name: dune-${{ matrix.name }} + combine: + runs-on: ubuntu-latest + needs: binary + steps: + - uses: actions/upload-artifact/merge@v4 + with: + separate-directories: true diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index 897ea4e0ebc..0b52307c6ea 100644 --- a/.github/workflows/workflow.yml +++ b/.github/workflows/workflow.yml @@ -34,7 +34,7 @@ jobs: - 4.14.x include: # OCaml trunk: - - ocaml-compiler: ocaml-variants.5.2.0+trunk + - ocaml-compiler: ocaml-variants.5.3.0+trunk os: ubuntu-latest skip_test: true # OCaml 5: @@ -44,6 +44,10 @@ jobs: - ocaml-compiler: 5.1.x os: macos-latest skip_test: true + # macOS x86_64 (Intel) + - ocaml-compiler: 4.14.x + os: macos-13 + skip_test: true # OCaml 4: - ocaml-compiler: 4.13.x os: ubuntu-latest diff --git a/Makefile b/Makefile index 8ea63c0f895..ebcb528204a 100644 --- a/Makefile +++ b/Makefile @@ -74,9 +74,10 @@ install-ocamlformat: dev-depext: opam depext -y $(TEST_DEPS) +# v4-414-dev .PHONY: melange melange: - opam pin add -n melange.dev https://github.com/melange-re/melange.git#v4-414-dev + opam pin add -n melange.dev https://github.com/melange-re/melange.git#24e21cc42 .PHONY: dev-deps dev-deps: melange diff --git a/bench/bench.ml b/bench/bench.ml index cfa48d3b49e..e309a74de59 100644 --- a/bench/bench.ml +++ b/bench/bench.ml @@ -365,8 +365,7 @@ let () = Dune_engine.Clflags.display := Quiet; { Scheduler.Config.concurrency = 10 ; stats = None - ; insignificant_changes = `React - ; signal_watcher = `No + ; print_ctrl_c_warning = false ; watch_exclusions = [] } in diff --git a/bench/micro/dune_bench/scheduler_bench.ml b/bench/micro/dune_bench/scheduler_bench.ml index 59b276b00b7..a6d88ae4216 100644 --- a/bench/micro/dune_bench/scheduler_bench.ml +++ b/bench/micro/dune_bench/scheduler_bench.ml @@ -8,8 +8,7 @@ let config = Dune_engine.Clflags.display := Short; { Scheduler.Config.concurrency = 1 ; stats = None - ; insignificant_changes = `React - ; signal_watcher = `No + ; print_ctrl_c_warning = false ; watch_exclusions = [] } ;; diff --git a/bin/common.ml b/bin/common.ml index 2ce0bc66bfd..66278b666ac 100644 --- a/bin/common.ml +++ b/bin/common.ml @@ -1047,14 +1047,6 @@ let rpc t = | `Allow rpc -> `Allow (Lazy.force rpc) ;; -let signal_watcher t = - match t.rpc with - | `Allow _ -> `Yes - | `Forbid_builds -> - (* if we aren't building anything, then we don't mind interrupting dune immediately *) - `No -;; - let watch_exclusions t = t.builder.watch_exclusions let stats t = t.stats diff --git a/bin/common.mli b/bin/common.mli index 6e1e5f33aeb..113de7ca515 100644 --- a/bin/common.mli +++ b/bin/common.mli @@ -14,7 +14,6 @@ val rpc | `Forbid_builds (** Promise not to build anything. For now, this isn't checked *) ] -val signal_watcher : t -> [ `Yes | `No ] val watch_exclusions : t -> string list val stats : t -> Dune_stats.t option val print_metrics : t -> bool diff --git a/bin/describe/describe.ml b/bin/describe/describe.ml index a844b802d4a..e37f3b49e7a 100644 --- a/bin/describe/describe.ml +++ b/bin/describe/describe.ml @@ -19,6 +19,7 @@ let subcommands = ; Aliases_targets.Aliases_cmd.command ; Package_entries.command ; Describe_pkg.command + ; Describe_contexts.command ] ;; diff --git a/bin/describe/describe_contexts.ml b/bin/describe/describe_contexts.ml new file mode 100644 index 00000000000..b0119d902cf --- /dev/null +++ b/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 +;; diff --git a/bin/describe/describe_contexts.mli b/bin/describe/describe_contexts.mli new file mode 100644 index 00000000000..5422c3c119b --- /dev/null +++ b/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 diff --git a/bin/describe/describe_pkg.ml b/bin/describe/describe_pkg.ml index 92ca484ea97..127add48001 100644 --- a/bin/describe/describe_pkg.ml +++ b/bin/describe/describe_pkg.ml @@ -145,21 +145,21 @@ module List_locked_dependencies = struct Pp.concat ~sep:Pp.cut (List.map lock_dirs_by_path ~f:(fun (lock_dir_path, lock_dir) -> - match Package_universe.create local_packages lock_dir with - | Error e -> raise (User_error.E e) - | Ok package_universe -> - Pp.vbox - (Pp.concat - ~sep:Pp.cut - [ Pp.hbox - (Pp.textf - "Dependencies of local packages locked in %s" - (Path.Source.to_string_maybe_quoted lock_dir_path)) - ; Pp.enumerate - (Package_name.Map.keys local_packages) - ~f:(package_deps_in_lock_dir_pp package_universe ~transitive) - |> Pp.box - ]))) + let package_universe = + Package_universe.create local_packages lock_dir |> User_error.ok_exn + in + Pp.vbox + (Pp.concat + ~sep:Pp.cut + [ Pp.hbox + (Pp.textf + "Dependencies of local packages locked in %s" + (Path.Source.to_string_maybe_quoted lock_dir_path)) + ; Pp.enumerate + (Package_name.Map.keys local_packages) + ~f:(package_deps_in_lock_dir_pp package_universe ~transitive) + |> Pp.box + ]))) |> Pp.vbox in Console.print [ pp ] diff --git a/bin/describe/describe_workspace.ml b/bin/describe/describe_workspace.ml index 28230fa093e..03278647dfb 100644 --- a/bin/describe/describe_workspace.ml +++ b/bin/describe/describe_workspace.ml @@ -274,12 +274,13 @@ module Sanitize_for_tests = struct let fake_workspace = lazy (Path.External.of_string "/WORKSPACE_ROOT") let sanitize_with_findlib ~findlib_paths path = + let path = Path.external_ path in List.find_map findlib_paths ~f:(fun candidate -> let open Option.O in let* candidate = Path.as_external candidate in (* if the path to rename is an external path, try to find the OCaml root inside, and replace it with a fixed string *) - let+ without_prefix = Path.External.drop_prefix ~prefix:candidate path in + let+ without_prefix = Path.drop_prefix ~prefix:(Path.external_ candidate) path in (* we have found the OCaml root path: let's replace it with a constant string *) Path.External.append_local (Lazy.force fake_findlib) without_prefix) @@ -371,7 +372,9 @@ module Crawl = struct (* Builds the list of modules *) let modules ~obj_dir ~deps_of modules_ : Descr.Mod.t list Memo.t = - Modules.fold_no_vlib ~init:(Memo.return []) modules_ ~f:(fun m macc -> + modules_ + |> Modules.With_vlib.drop_vlib + |> Modules.fold ~init:(Memo.return []) ~f:(fun m macc -> let* acc = macc in let deps = deps_of m in let+ { Ocaml.Ml_kind.Dict.intf = deps_for_intf; impl = deps_for_impl }, _ = @@ -389,11 +392,14 @@ module Crawl = struct Scope.DB.find_by_project (Super_context.context sctx |> Context.name) project in let* modules_, obj_dir = - Dir_contents.get sctx ~dir - >>= Dir_contents.ocaml - >>= Ml_sources.modules_and_obj_dir - ~libs:(Scope.libs scope) - ~for_:(Exe { first_exe }) + let+ modules_, obj_dir = + Dir_contents.get sctx ~dir + >>= Dir_contents.ocaml + >>= Ml_sources.modules_and_obj_dir + ~libs:(Scope.libs scope) + ~for_:(Exe { first_exe }) + in + Modules.With_vlib.modules modules_, obj_dir in let* pp_map = let+ version = @@ -454,11 +460,14 @@ module Crawl = struct let* libs = Scope.DB.find_by_dir (Path.as_in_build_dir_exn src_dir) >>| Scope.libs in - Dir_contents.get sctx ~dir:(Path.as_in_build_dir_exn src_dir) - >>= Dir_contents.ocaml - >>= Ml_sources.modules_and_obj_dir - ~libs - ~for_:(Library (Lib_info.lib_id info |> Lib_id.to_local_exn)) + let+ modules_, obj_dir_ = + Dir_contents.get sctx ~dir:(Path.as_in_build_dir_exn src_dir) + >>= Dir_contents.ocaml + >>= Ml_sources.modules_and_obj_dir + ~libs + ~for_:(Library (Lib_info.lib_id info |> Lib_id.to_local_exn)) + in + Modules.With_vlib.modules modules_, obj_dir_ in let* pp_map = let+ version = diff --git a/bin/import.ml b/bin/import.ml index b93831be48a..0d4a8cdecd8 100644 --- a/bin/import.ml +++ b/bin/import.ml @@ -189,13 +189,11 @@ module Scheduler = struct let go ~(common : Common.t) ~config:dune_config f = let stats = Common.stats common in let config = - let signal_watcher = Common.signal_watcher common in let watch_exclusions = Common.watch_exclusions common in Dune_config.for_scheduler dune_config stats - ~insignificant_changes:`Ignore - ~signal_watcher + ~print_ctrl_c_warning:true ~watch_exclusions in let f = @@ -218,13 +216,11 @@ module Scheduler = struct in let stats = Common.stats common in let config = - let signal_watcher = Common.signal_watcher common in let watch_exclusions = Common.watch_exclusions common in Dune_config.for_scheduler dune_config stats - ~insignificant_changes:`Ignore - ~signal_watcher + ~print_ctrl_c_warning:true ~watch_exclusions in let file_watcher = Common.file_watcher common in diff --git a/bin/monitor.ml b/bin/monitor.ml index 03f05d12b0c..383b4a51f7e 100644 --- a/bin/monitor.ml +++ b/bin/monitor.ml @@ -282,8 +282,7 @@ let command = Dune_config.for_scheduler config stats - ~insignificant_changes:`Ignore - ~signal_watcher:`Yes + ~print_ctrl_c_warning:true ~watch_exclusions:[] in Scheduler.Run.go diff --git a/bin/ocaml/ocaml_merlin.ml b/bin/ocaml/ocaml_merlin.ml index 7ee94602065..e68a5cd3617 100644 --- a/bin/ocaml/ocaml_merlin.ml +++ b/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,35 +150,39 @@ 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 -> @@ -165,12 +190,13 @@ end = struct 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,7 +218,8 @@ 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 @@ -200,7 +227,7 @@ module Dump_config = struct 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,7 +249,8 @@ 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 @@ -230,7 +258,7 @@ let start_session_term = 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 diff --git a/bin/ocaml/top.ml b/bin/ocaml/top.ml index 40607dc8d53..2073171c76b 100644 --- a/bin/ocaml/top.ml +++ b/bin/ocaml/top.ml @@ -181,7 +181,7 @@ module Module = struct let+ (pp, ppx), files_to_load = Memo.fork_and_join pps files_to_load in let code = let modules = Dune_rules.Compilation_context.modules cctx in - let opens_ = Dune_rules.Modules.local_open modules module_ in + let opens_ = Dune_rules.Modules.With_vlib.local_open modules module_ in List.map opens_ ~f:(fun name -> sprintf "open %s" (Dune_rules.Module_name.to_string name)) in diff --git a/bin/subst.ml b/bin/subst.ml index 57ec72113a7..2bc98511982 100644 --- a/bin/subst.ml +++ b/bin/subst.ml @@ -483,8 +483,7 @@ let term = config ~watch_exclusions:[] None - ~insignificant_changes:`React - ~signal_watcher:`No) + ~print_ctrl_c_warning:false) subst ;; diff --git a/doc/changes/10324.md b/doc/changes/10324.md new file mode 100644 index 00000000000..9e6f2577c5f --- /dev/null +++ b/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) diff --git a/doc/changes/8567.md b/doc/changes/8567.md new file mode 100644 index 00000000000..64cd6d2ca9d --- /dev/null +++ b/doc/changes/8567.md @@ -0,0 +1,3 @@ +- merlin: add optional `(merlin_reader CMD)` construct to `(dialect)` stanza to + configure a merlin reader (#8567, @andreypopp) + diff --git a/doc/reference/aliases.rst b/doc/reference/aliases.rst index fe71eaed474..3744ec0080f 100644 --- a/doc/reference/aliases.rst +++ b/doc/reference/aliases.rst @@ -64,6 +64,11 @@ Some aliases are defined and managed by Dune itself. This alias corresponds to every known file target in a directory. +Since version 2.0 of the dune language, JS targets of executables are no longer +included in the `all` alias by default. To get back the old behavior of +including the JS targets in `all`, one can add the ``js`` target to the +executable's ``modes`` field. + @check ^^^^^^ diff --git a/doc/reference/dune-workspace/context.rst b/doc/reference/dune-workspace/context.rst index 8f5dbdf1410..af42d8ecc90 100644 --- a/doc/reference/dune-workspace/context.rst +++ b/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 )`` sets a different profile for a :term:`build context`. This has precedence over the command-line option ``--profile``. diff --git a/flake.lock b/flake.lock index 6e7b356c3ba..43044dead19 100644 --- a/flake.lock +++ b/flake.lock @@ -5,11 +5,11 @@ "systems": "systems" }, "locked": { - "lastModified": 1705309234, - "narHash": "sha256-uNRRNRKmJyCRC/8y1RqBkqWBLM034y4qN7EprSdmgyA=", + "lastModified": 1710146030, + "narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=", "owner": "numtide", "repo": "flake-utils", - "rev": "1ef2e671c3b0c19053962c07dbda38332dcebf26", + "rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a", "type": "github" }, "original": { @@ -39,8 +39,8 @@ }, "original": { "owner": "melange-re", - "ref": "v4-414-dev", "repo": "melange", + "rev": "24e21cc4284ffb18b3a856c1d730f06f34d32737", "type": "github" } }, @@ -87,11 +87,11 @@ }, "nixpkgs": { "locked": { - "lastModified": 1708532945, - "narHash": "sha256-0KucnySzsz5Zgonjjm8cQMql+HGHa/OhB0fnKmGeD+0=", + "lastModified": 1715037484, + "narHash": "sha256-OUt8xQFmBU96Hmm4T9tOWTu4oCswCzoVl+pxSq/kiFc=", "owner": "nixos", "repo": "nixpkgs", - "rev": "ac4c5a60bebfb783f1106d126b9f39cc8e809e0e", + "rev": "ad7efee13e0d216bf29992311536fce1d3eefbef", "type": "github" }, "original": { @@ -101,6 +101,29 @@ "type": "github" } }, + "ocaml-overlays": { + "inputs": { + "flake-utils": [ + "flake-utils" + ], + "nixpkgs": [ + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1714974335, + "narHash": "sha256-03SXvaoRxfMUCL6Qt0kN1rEk1GceGEE9qTNP+EbGl+8=", + "owner": "nix-ocaml", + "repo": "nix-overlays", + "rev": "c7910ddfcd56cf67558dc24f3df99fb2a84317ce", + "type": "github" + }, + "original": { + "owner": "nix-ocaml", + "repo": "nix-overlays", + "type": "github" + } + }, "ocamllsp": { "inputs": { "flake-utils": [ @@ -111,11 +134,11 @@ ] }, "locked": { - "lastModified": 1708563706, - "narHash": "sha256-9Mt5hD3W0hDyIcPos9anTFRW7RHjEg3+2inj6jOY2S4=", + "lastModified": 1713734511, + "narHash": "sha256-WytVDQJz0i3arHUDVSj+b/9/IQq/z9wBrkSeQDIZAgU=", "ref": "refs/heads/master", - "rev": "922a726d2dcd816263c34df7d8d0f44fd4700be2", - "revCount": 2062, + "rev": "e485128b11892dc1e6a17f28b687368f2ac0db32", + "revCount": 2067, "submodules": true, "type": "git", "url": "https://github.com/ocaml/ocaml-lsp" @@ -131,6 +154,7 @@ "flake-utils": "flake-utils", "melange": "melange", "nixpkgs": "nixpkgs", + "ocaml-overlays": "ocaml-overlays", "ocamllsp": "ocamllsp" } }, diff --git a/flake.nix b/flake.nix index 95b2fe58f18..30ed86c453b 100644 --- a/flake.nix +++ b/flake.nix @@ -9,7 +9,12 @@ }; melange = { # When moving the compiler tests to OCaml 5.1, change to v4-51-dev - url = "github:melange-re/melange/v4-414-dev"; + url = "github:melange-re/melange?rev=24e21cc4284ffb18b3a856c1d730f06f34d32737"; + inputs.nixpkgs.follows = "nixpkgs"; + inputs.flake-utils.follows = "flake-utils"; + }; + ocaml-overlays = { + url = "github:nix-ocaml/nix-overlays"; inputs.nixpkgs.follows = "nixpkgs"; inputs.flake-utils.follows = "flake-utils"; }; @@ -20,6 +25,7 @@ , nixpkgs , ocamllsp , melange + , ocaml-overlays }: flake-utils.lib.eachDefaultSystem (system: let @@ -37,6 +43,24 @@ melange.overlays.default ocamllsp.overlays.default ]; + dune-static-overlay = self: super: { + ocamlPackages = super.ocaml-ng.ocamlPackages_4_14.overrideScope (oself: osuper: { + dune_3 = osuper.dune_3.overrideAttrs (a: { + src = ./.; + postPatch = '' + substituteInPlace \ + boot/duneboot.ml \ + --replace-fail \ + '; link_flags' \ + '; link_flags; ["-ccopt"; "-static"]' + ''; + }); + }); + }; + pkgs-static = nixpkgs.legacyPackages.${system}.appendOverlays [ + ocaml-overlays.overlays.default + dune-static-overlay + ]; ocamlformat = let @@ -79,6 +103,7 @@ installFlags = [ "PREFIX=${placeholder "out"}" "LIBDIR=$(OCAMLFIND_DESTDIR)" ]; }; dune = default; + dune-static = pkgs-static.pkgsCross.musl64.ocamlPackages.dune; }; devShells = diff --git a/otherlibs/ocamlc-loc/test/ocamlc_loc_tests.ml b/otherlibs/ocamlc-loc/test/ocamlc_loc_tests.ml index 6c51501107d..7b6d6363e6d 100644 --- a/otherlibs/ocamlc-loc/test/ocamlc_loc_tests.ml +++ b/otherlibs/ocamlc-loc/test/ocamlc_loc_tests.ml @@ -307,7 +307,6 @@ File "test/expect-tests/timer_tests.ml", lines 6-10, characters 2-3: 6 | ..{ Scheduler.Config.concurrency = 1 7 | ; display = { verbosity = Short; status_line = false } 8 | ; stats = None - 9 | ; insignificant_changes = `React 10 | } Error: Some record fields are undefined: signal_watcher |}; diff --git a/otherlibs/stdune/src/path.ml b/otherlibs/stdune/src/path.ml index 690ade67302..01c1feedab8 100644 --- a/otherlibs/stdune/src/path.ml +++ b/otherlibs/stdune/src/path.ml @@ -496,22 +496,11 @@ module External : sig val as_local : t -> string val append_local : t -> Local.t -> t val of_filename_relative_to_initial_cwd : string -> t - val drop_prefix : t -> prefix:t -> Local.t option end = struct module Table = String.Table type t = string - let drop_prefix path ~prefix = - if prefix = path - then Some Local.root - else ( - let prefix = prefix ^ "/" in - let open Option.O in - let+ suffix = String.drop_prefix path ~prefix in - Local.of_string suffix) - ;; - let to_string t = t let equal = String.equal let hash = String.hash @@ -1458,7 +1447,10 @@ let drop_prefix path ~prefix = if prefix = path then Some Local.root else ( - let prefix = to_string prefix ^ "/" in + let prefix_s = to_string prefix in + let prefix = + if String.is_suffix ~suffix:"/" prefix_s then prefix_s else prefix_s ^ "/" + in let open Option.O in let+ suffix = String.drop_prefix (to_string path) ~prefix in Local.of_string suffix) diff --git a/otherlibs/stdune/src/path.mli b/otherlibs/stdune/src/path.mli index ab1e94bd87a..a9e763cd97f 100644 --- a/otherlibs/stdune/src/path.mli +++ b/otherlibs/stdune/src/path.mli @@ -78,7 +78,6 @@ module External : sig val mkdir_p : ?perms:int -> t -> unit val of_filename_relative_to_initial_cwd : string -> t val append_local : t -> Local.t -> t - val drop_prefix : t -> prefix:t -> Local.t option module Table : Hashtbl.S with type key = t end diff --git a/otherlibs/stdune/test/path_tests.ml b/otherlibs/stdune/test/path_tests.ml index aa675f68fb7..27b9d915138 100644 --- a/otherlibs/stdune/test/path_tests.ml +++ b/otherlibs/stdune/test/path_tests.ml @@ -574,9 +574,9 @@ let%expect_test "drop prefix" = ;; let%expect_test "drop external prefix" = - Path.External.drop_prefix - ~prefix:(Path.External.of_filename_relative_to_initial_cwd "foo/bar") - (Path.External.of_filename_relative_to_initial_cwd "foo/bar/baz") + Path.drop_prefix + ~prefix:(Path.of_filename_relative_to_initial_cwd "foo/bar") + (Path.of_filename_relative_to_initial_cwd "foo/bar/baz") |> Dyn.option Path.Local.to_dyn |> print_dyn; [%expect {| Some "baz" |}] @@ -590,9 +590,9 @@ let%expect_test "drop prefix as substring" = ;; let%expect_test "drop external prefix as substring" = - Path.External.drop_prefix - ~prefix:(Path.External.of_filename_relative_to_initial_cwd "foo/bar") - (Path.External.of_filename_relative_to_initial_cwd "foo/barbaz") + Path.drop_prefix + ~prefix:(Path.of_filename_relative_to_initial_cwd "foo/bar") + (Path.of_filename_relative_to_initial_cwd "foo/barbaz") |> Dyn.option Path.Local.to_dyn |> print_dyn; [%expect {| None |}] @@ -605,7 +605,14 @@ let%expect_test "drop entire path" = ;; let%expect_test "drop entire external path" = - let path = Path.External.of_filename_relative_to_initial_cwd "foo/bar" in - Path.External.drop_prefix ~prefix:path path |> Dyn.option Path.Local.to_dyn |> print_dyn; + let path = Path.of_filename_relative_to_initial_cwd "foo/bar" in + Path.drop_prefix ~prefix:path path |> Dyn.option Path.Local.to_dyn |> print_dyn; [%expect {| Some "." |}] ;; + +let%expect_test "drop prefix with a trailing /" = + Path.drop_prefix ~prefix:(Path.of_string "/a/b/c/") (Path.of_string "/a/b/c/d/e") + |> Dyn.option Path.Local.to_dyn + |> print_dyn; + [%expect {| Some "d/e" |}] +;; diff --git a/src/dune_config_file/dune_config_file.ml b/src/dune_config_file/dune_config_file.ml index fc3c88b62c3..0b31881b547 100644 --- a/src/dune_config_file/dune_config_file.ml +++ b/src/dune_config_file/dune_config_file.ml @@ -486,8 +486,7 @@ module Dune_config = struct loop commands)) ;; - let for_scheduler (t : t) ~watch_exclusions stats ~insignificant_changes ~signal_watcher - = + let for_scheduler (t : t) ~watch_exclusions stats ~print_ctrl_c_warning = let concurrency = match t.concurrency with | Fixed i -> i @@ -500,11 +499,6 @@ module Dune_config = struct := match t.display with | Tui -> Dune_engine.Display.Quiet | Simple { verbosity; _ } -> verbosity); - { Scheduler.Config.concurrency - ; stats - ; insignificant_changes - ; signal_watcher - ; watch_exclusions - } + { Scheduler.Config.concurrency; stats; print_ctrl_c_warning; watch_exclusions } ;; end diff --git a/src/dune_config_file/dune_config_file.mli b/src/dune_config_file/dune_config_file.mli index af1105af1c5..0f33225084b 100644 --- a/src/dune_config_file/dune_config_file.mli +++ b/src/dune_config_file/dune_config_file.mli @@ -102,15 +102,13 @@ module Dune_config : sig val hash : t -> int val equal : t -> t -> bool - (** [for_scheduler config ?watch_exclusions stats_opt ~insignificant_changes - ~signal_watcher] + (** [for_scheduler config ?watch_exclusions stats_opt ~signal_watcher] creates a configuration for a scheduler from the user-visible Dune [config]. *) val for_scheduler : t -> watch_exclusions:string list -> Dune_stats.t option - -> insignificant_changes:[ `React | `Ignore ] - -> signal_watcher:[ `Yes | `No ] + -> print_ctrl_c_warning:bool -> Dune_engine.Scheduler.Config.t end diff --git a/src/dune_engine/action_runner.ml b/src/dune_engine/action_runner.ml index e2a22b01899..586ef2377e9 100644 --- a/src/dune_engine/action_runner.ml +++ b/src/dune_engine/action_runner.ml @@ -360,7 +360,7 @@ module Worker = struct Action_exec.exec ~build_deps action ;; - let cancel_build = Scheduler.stop_on_first_error + let cancel_build = Scheduler.cancel_current_build let start ~name ~where = let* connection = Client.Connection.connect_exn where in diff --git a/src/dune_engine/build_system.ml b/src/dune_engine/build_system.ml index 007b8796191..ef0b19045bd 100644 --- a/src/dune_engine/build_system.ml +++ b/src/dune_engine/build_system.ml @@ -1111,7 +1111,7 @@ let report_early_exn exn = (Build_config.get ()).action_runners () |> Fiber.parallel_iter ~f:Action_runner.cancel_build in - Scheduler.stop_on_first_error () + Scheduler.cancel_current_build () | false -> Fiber.return () in (match !Clflags.report_errors_config with diff --git a/src/dune_engine/scheduler.ml b/src/dune_engine/scheduler.ml index ae6ab3ca3e5..d17ffed1839 100644 --- a/src/dune_engine/scheduler.ml +++ b/src/dune_engine/scheduler.ml @@ -7,8 +7,7 @@ module Config = struct type t = { concurrency : int ; stats : Dune_stats.t option - ; insignificant_changes : [ `Ignore | `React ] - ; signal_watcher : [ `Yes | `No ] + ; print_ctrl_c_warning : bool ; watch_exclusions : string list } end @@ -70,7 +69,7 @@ let blocked_signals : Signal.t list = ;; module Thread : sig - val spawn : signal_watcher:[ `Yes | `No ] -> (unit -> unit) -> unit + val spawn : (unit -> unit) -> unit val delay : float -> unit val wait_signal : int list -> int end = struct @@ -82,34 +81,30 @@ end = struct ignore (Unix.sigprocmask SIG_BLOCK signos : int list)) ;; - let create ~signal_watcher = + let create = if Sys.win32 then Thread.create else (* On unix, we make sure to block signals globally before starting a thread so that only the signal watcher thread can receive signals. *) fun f x -> - let () = - match signal_watcher with - | `Yes -> Lazy.force block_signals - | `No -> () - in + Lazy.force block_signals; Thread.create f x ;; - let spawn ~signal_watcher f = + let spawn f = let f () = try f () with | exn -> let exn = Exn_with_backtrace.capture exn in Dune_util.Report_error.report exn in - let (_ : Thread.t) = create ~signal_watcher f () in + let (_ : Thread.t) = create f () in () ;; end -let spawn_thread f = Thread.spawn ~signal_watcher:`Yes f +let spawn_thread f = Thread.spawn f (** The event queue *) module Event : sig @@ -123,7 +118,6 @@ module Event : sig | File_system_sync of Dune_file_watcher.Sync_id.t | File_system_watcher_terminated | Shutdown of Shutdown.Reason.t - | Stop_on_first_error | Fiber_fill_ivar of Fiber.fill module Queue : sig @@ -159,7 +153,6 @@ module Event : sig val send_invalidation_event : t -> Memo.Invalidation.t -> unit val send_job_completed : t -> job -> Proc.Process_info.t -> unit val send_shutdown : t -> Shutdown.Reason.t -> unit - val send_stop_on_first_error : t -> unit val send_timers_completed : t -> Fiber.fill Nonempty_list.t -> unit val yield_if_there_are_pending_events : t -> unit Fiber.t end @@ -174,7 +167,6 @@ end = struct | File_system_sync of Dune_file_watcher.Sync_id.t | File_system_watcher_terminated | Shutdown of Shutdown.Reason.t - | Stop_on_first_error | Fiber_fill_ivar of Fiber.fill module Invalidation_event = struct @@ -191,7 +183,6 @@ end = struct ; file_watcher_tasks : (unit -> Dune_file_watcher.Event.t list) Queue.t ; mutable invalidation_events : Invalidation_event.t list ; mutable shutdown_reasons : Shutdown.Reason.Set.t - ; mutable got_stop_on_first_error : bool ; mutex : Mutex.t ; cond : Condition.t ; mutable pending_jobs : int @@ -219,7 +210,6 @@ end = struct ; invalidation_events ; timers ; shutdown_reasons - ; got_stop_on_first_error = false ; mutex ; cond ; pending_jobs @@ -266,7 +256,6 @@ end = struct type t val shutdown : t - val stop_on_first_error : t val file_watcher_task : t val invalidation : t val jobs_completed : t @@ -288,15 +277,6 @@ end = struct Shutdown reason) ;; - let stop_on_first_error : t = - fun q -> - match q.got_stop_on_first_error with - | true -> - q.got_stop_on_first_error <- false; - Some Stop_on_first_error - | false -> None - ;; - let file_watcher_task q = Option.map (Queue.pop q.file_watcher_tasks) ~f:(fun job -> File_watcher_task job) ;; @@ -386,7 +366,6 @@ end = struct ; jobs_completed ; yield ; timers - ; stop_on_first_error ])) q with @@ -433,10 +412,6 @@ end = struct q.shutdown_reasons <- Shutdown.Reason.Set.add q.shutdown_reasons signal) ;; - let send_stop_on_first_error q = - add_event q (fun q -> q.got_stop_on_first_error <- true) - ;; - let send_file_watcher_task q job = add_event q (fun q -> Queue.push q.file_watcher_tasks job) ;; @@ -483,7 +458,7 @@ module Process_watcher : sig (** Initialize the process watcher thread. *) type t - val init : signal_watcher:[ `Yes | `No ] -> Event.Queue.t -> t + val init : Event.Queue.t -> t (** Register a new running job. *) val register_job : t -> job -> unit @@ -618,7 +593,7 @@ end = struct done ;; - let init ~signal_watcher events = + let init events = let t = { mutex = Mutex.create () ; something_is_running = Condition.create () @@ -627,13 +602,13 @@ end = struct ; running_count = 0 } in - Thread.spawn ~signal_watcher (fun () -> run t); + Thread.spawn (fun () -> run t); t ;; end module Signal_watcher : sig - val init : Event.Queue.t -> unit + val init : print_ctrl_c_warning:bool -> Event.Queue.t -> unit end = struct let signos = List.map interrupt_signals ~f:Signal.to_int @@ -663,7 +638,7 @@ end = struct else Staged.stage (fun () -> Thread.wait_signal signos |> Signal.of_int) ;; - let run q = + let run ~print_ctrl_c_warning q = let last_exit_signals = Queue.create () in let wait_signal = Staged.unstage (signal_waiter ()) in while true do @@ -681,32 +656,19 @@ end = struct ignore (Queue.pop_exn last_exit_signals : float) done; let n = Queue.length last_exit_signals in - if n = 2 then prerr_endline warning; + if n = 2 && print_ctrl_c_warning then prerr_endline warning; if n = 3 then sys_exit 1 | _ -> (* we only blocked the signals above *) assert false done ;; - let init q = Thread.spawn ~signal_watcher:`Yes (fun () -> run q) + let init ~print_ctrl_c_warning q = Thread.spawn (fun () -> run ~print_ctrl_c_warning q) end type status = | (* We are not doing a build. Just accumulating invalidations until the next build starts. *) - Standing_by of - { invalidation : Memo.Invalidation.t - ; saw_insignificant_changes : bool - (* When [insignificant_changes = `Ignore], this field is always - false. - - When [insignificant_changes = `React], we do the following: - - Whether we saw build input changes that are insignificant for - the build. We need to track this because we still want to start - a new build in this case, even if we know it's going to be a - no-op. We do that so that RPC clients can observe that Dune - reacted to the change. *) - } + Standing_by of { invalidation : Memo.Invalidation.t } | (* Running a build *) Building of Fiber.Cancel.t | (* Cancellation requested. Build jobs are immediately rejected in this @@ -734,7 +696,7 @@ end module Alarm_clock : sig type t - val create : signal_watcher:[ `Yes | `No ] -> Event.Queue.t -> frequency:float -> t + val create : Event.Queue.t -> frequency:float -> t type alarm @@ -795,9 +757,9 @@ end = struct Mutex.unlock t.mutex ;; - let create ~signal_watcher events ~frequency = + let create events ~frequency = let t = { events; active = true; alarms = []; frequency; mutex = Mutex.create () } in - Thread.spawn ~signal_watcher (polling_loop t); + Thread.spawn (polling_loop t); t ;; @@ -820,41 +782,18 @@ end = struct ;; end -(** All fields of [t] must be immutable. This is because we re-create [t] every - time we start a new build to locally set the [cancel] field. However, all - instances of [t] must share all other fields, in particular the references - such as [status]. - - Another option would be to split [t] in two records such as: - - {[ - type shared = { blah : blah } - - type t = - { shared : shared - ; cancel : Fiber.Cancel.t - } - ]} - - However, this style is more heavy. What is more, it means that every access - to shared fields of [t] is now slower. - - With the current approach setting the cancellation is slower as it requires - copying almost all fields of [t]. However this happens only once per build - and a build is a much heavier operation than copying this record, so it's - fine. *) type t = { config : Config.t ; alarm_clock : Alarm_clock.t Lazy.t - ; status : status ref + ; mutable status : status ; handler : Handler.t ; job_throttle : Fiber.Throttle.t ; events : Event.Queue.t ; process_watcher : Process_watcher.t ; file_watcher : Dune_file_watcher.t option ; fs_syncs : unit Fiber.Ivar.t Dune_file_watcher.Sync_id.Table.t - ; wait_for_build_input_change : unit Fiber.Ivar.t option ref - ; cancel : Fiber.Cancel.t + ; mutable wait_for_build_input_change : unit Fiber.Ivar.t option + ; mutable cancel : Fiber.Cancel.t ; thread_pool : Thread_pool.t } @@ -955,41 +894,32 @@ let kill_and_wait_for_all_processes t = !saw_signal ;; -let prepare (config : Config.t) ~(handler : Handler.t) = - let events = Event.Queue.create config.stats in - (* We return the scheduler in chunks to resolve the dependency cycle - (scheduler wants to know the file_watcher, file_watcher wants to send - events to scheduler) *) - let signal_watcher = config.signal_watcher in - ( events - , fun ~file_watcher -> - (* The signal watcher must be initialized first so that signals are - blocked in all threads. *) - (match signal_watcher with - | `Yes -> Signal_watcher.init events - | `No -> ()); - let cancel = Fiber.Cancel.create () in - let process_watcher = Process_watcher.init ~signal_watcher events in - { status = - (* Slightly weird initialization happening here: for polling mode we - initialize in "Building" state, immediately switch to Standing_by - and then back to "Building". It would make more sense to start in - "Stand_by" from the start. We can't "just" switch the initial value - here because then the non-polling mode would run in "Standing_by" - mode, which is even weirder. *) - ref (Building cancel) - ; job_throttle = Fiber.Throttle.create config.concurrency - ; process_watcher - ; events - ; config - ; handler - ; file_watcher - ; fs_syncs = Dune_file_watcher.Sync_id.Table.create 64 - ; wait_for_build_input_change = ref None - ; alarm_clock = lazy (Alarm_clock.create ~signal_watcher events ~frequency:0.1) - ; cancel - ; thread_pool = Thread_pool.create ~spawn_thread ~min_workers:4 ~max_workers:50 - } ) +let prepare (config : Config.t) ~(handler : Handler.t) ~events ~file_watcher = + (* The signal watcher must be initialized first so that signals are + blocked in all threads. *) + Signal_watcher.init ~print_ctrl_c_warning:config.print_ctrl_c_warning events; + let cancel = Fiber.Cancel.create () in + let process_watcher = Process_watcher.init events in + { status = + (* Slightly weird initialization happening here: for polling mode we + initialize in "Building" state, immediately switch to Standing_by + and then back to "Building". It would make more sense to start in + "Stand_by" from the start. We can't "just" switch the initial value + here because then the non-polling mode would run in "Standing_by" + mode, which is even weirder. *) + Building cancel + ; job_throttle = Fiber.Throttle.create config.concurrency + ; process_watcher + ; events + ; config + ; handler + ; file_watcher + ; fs_syncs = Dune_file_watcher.Sync_id.Table.create 64 + ; wait_for_build_input_change = None + ; alarm_clock = lazy (Alarm_clock.create events ~frequency:0.1) + ; cancel + ; thread_pool = Thread_pool.create ~spawn_thread ~min_workers:4 ~max_workers:50 + } ;; module Run_once : sig @@ -1047,60 +977,35 @@ end = struct | Shutdown reason -> got_shutdown reason; raise @@ Abort (Shutdown_requested reason) - | Stop_on_first_error -> - let fills = - match !(t.status) with - | Restarting_build _ -> [] - | Standing_by _ -> [] - | Building cancellation -> - t.handler t.config Build_interrupted; - t.status - := Standing_by - { invalidation = Memo.Invalidation.empty - ; saw_insignificant_changes = false - }; - Fiber.Cancel.fire' cancellation - in - (match Nonempty_list.of_list fills with - | None -> iter t - | Some fills -> fills) and build_input_change (t : t) events = let invalidation = handle_invalidation_events events in let significant_changes = not (Memo.Invalidation.is_empty invalidation) in - let insignificant_changes = - match t.config.insignificant_changes with - | `Ignore -> false - | `React -> not significant_changes - in let fills = - match !(t.status) with + match t.status with | Restarting_build prev_invalidation -> t.status - := Restarting_build (Memo.Invalidation.combine prev_invalidation invalidation); + <- Restarting_build (Memo.Invalidation.combine prev_invalidation invalidation); [] | Standing_by prev -> t.status - := Standing_by - { invalidation = Memo.Invalidation.combine prev.invalidation invalidation - ; saw_insignificant_changes = - prev.saw_insignificant_changes || insignificant_changes - }; + <- Standing_by + { invalidation = Memo.Invalidation.combine prev.invalidation invalidation }; [] | Building cancellation -> (match significant_changes with | false -> [] | true -> t.handler t.config Build_interrupted; - t.status := Restarting_build invalidation; + t.status <- Restarting_build invalidation; Fiber.Cancel.fire' cancellation) in match Nonempty_list.of_list @@ - match !(t.wait_for_build_input_change) with - | Some ivar when significant_changes || insignificant_changes -> - t.wait_for_build_input_change := None; + match t.wait_for_build_input_change with + | Some ivar when significant_changes -> + t.wait_for_build_input_change <- None; Fiber.Fill (ivar, ()) :: fills | _ -> fills with @@ -1176,17 +1081,16 @@ let flush_file_watcher t = ;; let wait_for_build_input_change t = - match !(t.wait_for_build_input_change) with + match t.wait_for_build_input_change with | Some ivar -> Fiber.Ivar.read ivar | None -> - (match !(t.status) with - | Standing_by { invalidation; saw_insignificant_changes } - when (not (Memo.Invalidation.is_empty invalidation)) || saw_insignificant_changes - -> Fiber.return () + (match t.status with + | Standing_by { invalidation } when not (Memo.Invalidation.is_empty invalidation) -> + Fiber.return () | Restarting_build _ -> Fiber.return () | Standing_by _ | Building _ -> let ivar = Fiber.Ivar.create () in - t.wait_for_build_input_change := Some ivar; + t.wait_for_build_input_change <- Some ivar; Fiber.Ivar.read ivar) ;; @@ -1204,16 +1108,17 @@ module Run = struct module Event = Handler.Event let rec poll_iter t step ~invalidation = - let cancel = Fiber.Cancel.create () in - t.status := Building cancel; if Memo.Invalidation.is_empty invalidation then Memo.Metrics.reset () else ( let details_hum = Memo.Invalidation.details_hum invalidation in t.handler t.config (Source_files_changed { details_hum }); Memo.reset invalidation); - let* res = set { t with cancel } (fun () -> step) in - match !(t.status) with + let cancel = Fiber.Cancel.create () in + t.status <- Building cancel; + t.cancel <- cancel; + let* res = step in + match t.status with | Standing_by _ -> let res : Build_outcome.t = match res with @@ -1229,15 +1134,13 @@ module Run = struct | Error `Already_reported -> Failure | Ok () -> Success in - t.status - := Standing_by - { invalidation = Memo.Invalidation.empty; saw_insignificant_changes = false }; + t.status <- Standing_by { invalidation = Memo.Invalidation.empty }; t.handler t.config (Build_finish res); Fiber.return res ;; let poll_iter t step = - match !(t.status) with + match t.status with | Building _ | Restarting_build _ -> assert false | Standing_by { invalidation; _ } -> poll_iter t step ~invalidation ;; @@ -1247,12 +1150,10 @@ module Run = struct let poll_init () = let+ t = t () in assert ( - match !(t.status) with + match t.status with | Building _ -> true | _ -> false); - t.status - := Standing_by - { invalidation = Memo.Invalidation.empty; saw_insignificant_changes = false }; + t.status <- Standing_by { invalidation = Memo.Invalidation.empty }; t ;; @@ -1318,13 +1219,13 @@ module Run = struct ;; let go - config + (config : Config.t) ?timeout ?(file_watcher = No_watcher) ~(on_event : Config.t -> Handler.Event.t -> unit) run = - let events, prepare = prepare config ~handler:on_event in + let events = Event_queue.create config.stats in let file_watcher = match file_watcher with | No_watcher -> None @@ -1332,14 +1233,14 @@ module Run = struct Some (Dune_file_watcher.create_default ~scheduler: - { spawn_thread = Thread.spawn ~signal_watcher:config.signal_watcher + { spawn_thread = Thread.spawn ; thread_safe_send_emit_events_job = (fun job -> Event_queue.send_file_watcher_task events job) } ~watch_exclusions:config.watch_exclusions ()) in - let t = prepare ~file_watcher in + let t = prepare config ~handler:on_event ~events ~file_watcher in let initial_invalidation = Fs_memo.init ~dune_file_watcher:file_watcher in Memo.reset initial_invalidation; let result = @@ -1388,9 +1289,14 @@ let shutdown () = Event.Queue.send_shutdown t.events Requested ;; -let stop_on_first_error () = - let+ t = t () in - Event.Queue.send_stop_on_first_error t.events +let cancel_current_build () = + let* t = t () in + match t.status with + | Restarting_build _ | Standing_by _ -> Fiber.return () + | Building cancellation -> + t.handler t.config Build_interrupted; + t.status <- Standing_by { invalidation = Memo.Invalidation.empty }; + Fiber.Cancel.fire cancellation ;; let inject_memo_invalidation invalidation = diff --git a/src/dune_engine/scheduler.mli b/src/dune_engine/scheduler.mli index 63893623228..58f5328f4f8 100644 --- a/src/dune_engine/scheduler.mli +++ b/src/dune_engine/scheduler.mli @@ -6,8 +6,7 @@ module Config : sig type t = { concurrency : int ; stats : Dune_stats.t option - ; insignificant_changes : [ `Ignore | `React ] - ; signal_watcher : [ `Yes | `No ] + ; print_ctrl_c_warning : bool ; watch_exclusions : string list } end @@ -140,7 +139,7 @@ val shutdown : unit -> unit Fiber.t in that it stops the build early, but it is different because the [Run.go] call is allowed to complete its fiber. In this respect, the behavior is similar to what happens on file system events in polling mode. *) -val stop_on_first_error : unit -> unit Fiber.t +val cancel_current_build : unit -> unit Fiber.t val inject_memo_invalidation : Memo.Invalidation.t -> unit Fiber.t diff --git a/src/dune_pkg/fetch.ml b/src/dune_pkg/fetch.ml index 79cb0260a1d..f44c91d5c0a 100644 --- a/src/dune_pkg/fetch.ml +++ b/src/dune_pkg/fetch.ml @@ -200,13 +200,7 @@ let with_download url checksum ~target ~f = let temp_dir = let prefix = "dune" in let suffix = Filename.basename url in - match (target : Path.t) with - | In_build_dir _ -> - Temp.temp_in_dir Dir ~dir:(Lazy.force Temp_dir.in_build) ~prefix ~suffix - | _ -> - let parent = Path.parent_exn target in - Path.mkdir_p parent; - Temp.temp_in_dir Dir ~dir:parent ~prefix ~suffix + Temp_dir.dir_for_target ~target ~prefix ~suffix in let output = Path.relative temp_dir "download" in Fiber.finalize ~finally:(fun () -> @@ -329,3 +323,11 @@ let fetch ~unpack ~checksum ~target ~url:(url_loc, url) = | `http -> fetch_curl ~unpack ~checksum ~target url | _ -> fetch_others ~unpack ~checksum ~target url) ;; + +let fetch_without_checksum ~unpack ~target ~url = + fetch ~unpack ~checksum:None ~url ~target + >>| function + | Ok () -> Ok () + | Error (Checksum_mismatch _) -> assert false + | Error (Unavailable message) -> Error message +;; diff --git a/src/dune_pkg/fetch.mli b/src/dune_pkg/fetch.mli index cc6c922a2a6..e0f508cd643 100644 --- a/src/dune_pkg/fetch.mli +++ b/src/dune_pkg/fetch.mli @@ -7,11 +7,11 @@ type failure = (** [fetch ~checksum ~target url] will fetch [url] into [target]. It will verify the downloaded file against [checksum], unless it [checksum] is [None]. - @raise Checksum_mismatch - When the downloaded file doesn't match the expected [checksum], this will - pass the actually computed checksum. - @raise Unavailable - When the file can't be retrieved, e.g. not available at the location. *) + return [Error (Checksum_mismatch _)] When the downloaded file doesn't match + the expected [checksum], this will pass the actually computed checksum. + + return [Error (Unavailable _))] When the file can't be retrieved, e.g. not + available at the location. *) val fetch : unpack:bool -> checksum:Checksum.t option @@ -19,6 +19,12 @@ val fetch -> url:Loc.t * OpamUrl.t -> (unit, failure) result Fiber.t +val fetch_without_checksum + : unpack:bool + -> target:Path.t + -> url:Loc.t * OpamUrl.t + -> (unit, User_message.t option) result Fiber.t + val fetch_git : Rev_store.t -> target:Path.t diff --git a/src/dune_pkg/lock_dir.ml b/src/dune_pkg/lock_dir.ml index b696ebbe975..94a8e4e1f52 100644 --- a/src/dune_pkg/lock_dir.ml +++ b/src/dune_pkg/lock_dir.ml @@ -217,6 +217,10 @@ module Pkg = struct ; field_l Fields.extra_sources encode_extra_source extra_sources ] ;; + + let files_dir package_name ~lock_dir = + Path.Source.relative lock_dir (Package_name.to_string package_name ^ ".files") + ;; end module Repositories = struct @@ -521,8 +525,8 @@ module Write_disk = struct type t = unit -> unit - let prepare ~lock_dir_path ~files lock_dir = - let lock_dir_path = Path.source lock_dir_path in + let prepare ~lock_dir_path:lock_dir_path_src ~files lock_dir = + let lock_dir_path = Path.source lock_dir_path_src in let remove_dir_if_exists = safely_remove_lock_dir_if_exists_thunk lock_dir_path in fun () -> remove_dir_if_exists (); @@ -535,11 +539,13 @@ module Write_disk = struct List.map contents ~f:(fun sexp -> Dune_sexp.Ast.add_loc ~loc:Loc.none sexp |> Dune_sexp.Cst.concrete) in + (* TODO the version should be chosen based on the version of the lock + directory we're outputting *) let pp = Dune_lang.Format.pp_top_sexps ~version:(3, 11) cst in Format.asprintf "%a" Pp.to_fmt pp |> Io.write_file path; Package_name.Map.iteri files ~f:(fun package_name files -> let files_dir = - Path.relative lock_dir_path (Package_name.to_string package_name ^ ".files") + Pkg.files_dir package_name ~lock_dir:lock_dir_path_src |> Path.source in Path.mkdir_p files_dir; List.iter files ~f:(fun { File_entry.original; local_file } -> diff --git a/src/dune_pkg/lock_dir.mli b/src/dune_pkg/lock_dir.mli index 8b77e22deb3..72d72a03478 100644 --- a/src/dune_pkg/lock_dir.mli +++ b/src/dune_pkg/lock_dir.mli @@ -31,6 +31,7 @@ module Pkg : sig val equal : t -> t -> bool val decode : (lock_dir:Path.Source.t -> Package_name.t -> t) Decoder.t + val files_dir : Package_name.t -> lock_dir:Path.Source.t -> Path.Source.t end module Repositories : sig diff --git a/src/dune_pkg/mount.ml b/src/dune_pkg/mount.ml index f5bf1588c3d..6b42da733c2 100644 --- a/src/dune_pkg/mount.ml +++ b/src/dune_pkg/mount.ml @@ -14,7 +14,14 @@ let of_opam_url loc url = match OpamUrl.local_or_git_only url loc with | `Path dir -> Fiber.return (Path dir) | `Git -> - let+ rev = Opam_repo.of_git_repo loc url >>| Opam_repo.revision in + let+ rev = + let* rev_store = Rev_store.get in + OpamUrl.resolve url ~loc rev_store + >>= (function + | Error _ as e -> Fiber.return e + | Ok s -> OpamUrl.fetch_revision url ~loc s rev_store) + >>| User_error.ok_exn + in Git rev ;; diff --git a/src/dune_pkg/opamUrl0.ml b/src/dune_pkg/opamUrl0.ml index 9e9c9361c1e..1d94371cced 100644 --- a/src/dune_pkg/opamUrl0.ml +++ b/src/dune_pkg/opamUrl0.ml @@ -32,9 +32,9 @@ let is_local t = String.equal t.transport "file" let local_or_git_only url loc = match (url : t).backend with - | `rsync -> `Path (Path.of_string url.path) + | `rsync when is_local url -> `Path (Path.of_string url.path) | `git -> `Git - | `http | `darcs | `hg -> + | `rsync | `http | `darcs | `hg -> User_error.raise ~loc ~hints:[ Pp.text "Specify either a file path or git repo via SSH/HTTPS" ] diff --git a/src/dune_pkg/opam_repo.ml b/src/dune_pkg/opam_repo.ml index f7c1063239a..5e102c77945 100644 --- a/src/dune_pkg/opam_repo.ml +++ b/src/dune_pkg/opam_repo.ml @@ -97,14 +97,10 @@ let of_git_repo loc url = let+ at_rev = let* rev_store = Rev_store.get in OpamUrl.resolve url ~loc rev_store - >>= function - | Error _ as e -> Fiber.return e - | Ok s -> OpamUrl.fetch_revision url ~loc s rev_store - in - let at_rev = - match at_rev with - | Ok s -> s - | Error m -> raise (User_error.E m) + >>= (function + | Error _ as e -> Fiber.return e + | Ok s -> OpamUrl.fetch_revision url ~loc s rev_store) + >>| User_error.ok_exn in let serializable = Some diff --git a/src/dune_pkg/rev_store.ml b/src/dune_pkg/rev_store.ml index 973a8dc313e..bb405c4a69b 100644 --- a/src/dune_pkg/rev_store.ml +++ b/src/dune_pkg/rev_store.ml @@ -710,13 +710,7 @@ module At_rev = struct let check_out { repo = { dir; _ }; revision = Sha1 rev; files = _ } ~target = (* TODO iterate over submodules to output sources *) let git = Lazy.force Vcs.git in - let temp_dir = - Temp.temp_in_dir - Dir - ~dir:(Lazy.force Temp_dir.in_build) - ~prefix:"rev-store" - ~suffix:rev - in + let temp_dir = Temp_dir.dir_for_target ~target ~prefix:"rev-store" ~suffix:rev in Fiber.finalize ~finally:(fun () -> let+ () = Fiber.return () in Temp.destroy Dir temp_dir) diff --git a/src/dune_pkg/source.ml b/src/dune_pkg/source.ml index 480b7ce8cb9..a1fb738fb73 100644 --- a/src/dune_pkg/source.ml +++ b/src/dune_pkg/source.ml @@ -50,12 +50,10 @@ let fetch_and_hash_archive_cached = fun (url_loc, url) -> let open Fiber.O in Single_run_file_cache.with_ cache ~key:(OpamUrl.to_string url) ~f:(fun target -> - Fetch.fetch ~unpack:false ~checksum:None ~target ~url:(url_loc, url)) + Fetch.fetch_without_checksum ~unpack:false ~target ~url:(url_loc, url)) >>| function | Ok target -> Some (Dune_digest.file target |> Checksum.of_dune_digest) - | Error (Checksum_mismatch _) -> - Code_error.raise "Checksum mismatch when no checksum was provided" [] - | Error (Unavailable message_opt) -> + | Error message_opt -> let message = match message_opt with | Some message -> message diff --git a/src/dune_pkg/tar.ml b/src/dune_pkg/tar.ml index 93465e5f62a..c952455644c 100644 --- a/src/dune_pkg/tar.ml +++ b/src/dune_pkg/tar.ml @@ -17,12 +17,7 @@ let extract ~archive ~target = let target_in_temp = let prefix = Path.basename target in let suffix = Path.basename archive in - match target with - | In_build_dir _ -> - Temp.temp_in_dir Dir ~dir:(Lazy.force Temp_dir.in_build) ~prefix ~suffix - | _ -> - let parent = Path.parent_exn target in - Temp.temp_in_dir Dir ~dir:parent ~prefix ~suffix + Temp_dir.dir_for_target ~target ~prefix ~suffix in Fiber.finalize ~finally:(fun () -> Temp.destroy Dir target_in_temp; diff --git a/src/dune_pkg/temp_dir.ml b/src/dune_pkg/temp_dir.ml index 0187692a9fd..8ed745badad 100644 --- a/src/dune_pkg/temp_dir.ml +++ b/src/dune_pkg/temp_dir.ml @@ -6,3 +6,12 @@ let in_build = Path.mkdir_p dir; dir) ;; + +let dir_for_target ~target ~prefix ~suffix = + match (target : Path.t) with + | In_build_dir _ -> Temp.temp_in_dir Dir ~dir:(Lazy.force in_build) ~prefix ~suffix + | _ -> + let parent = Path.parent_exn target in + Path.mkdir_p parent; + Temp.temp_in_dir Dir ~dir:parent ~prefix ~suffix +;; diff --git a/src/dune_pkg/temp_dir.mli b/src/dune_pkg/temp_dir.mli index 16938ecae3c..6fd96662c88 100644 --- a/src/dune_pkg/temp_dir.mli +++ b/src/dune_pkg/temp_dir.mli @@ -1,3 +1,3 @@ open Stdune -val in_build : Path.t Lazy.t +val dir_for_target : target:Path.t -> prefix:string -> suffix:string -> Path.t diff --git a/src/dune_rules/cinaps.ml b/src/dune_rules/cinaps.ml index fbaf9f27071..93ccee97229 100644 --- a/src/dune_rules/cinaps.ml +++ b/src/dune_rules/cinaps.ml @@ -151,8 +151,7 @@ let gen_rules sctx t ~dir ~scope = ~scope in let* modules = - Modules.singleton_exe module_ - |> Modules.map_user_written ~f:(Pp_spec.pp_module preprocess) + Pp_spec.pp_module preprocess module_ >>| Modules.With_vlib.singleton_exe in let dune_version = Scope.project scope |> Dune_project.dune_version in let names = [ t.loc, name ] in diff --git a/src/dune_rules/cm_files.ml b/src/dune_rules/cm_files.ml index 113955fc74a..83fe3476ee2 100644 --- a/src/dune_rules/cm_files.ml +++ b/src/dune_rules/cm_files.ml @@ -15,7 +15,7 @@ let filter_excluded_modules t modules = ;; let make ?(excluded_modules = []) ~obj_dir ~modules ~top_sorted_modules ~ext_obj () = - let modules = Modules.impl_only modules in + let modules = Modules.With_vlib.impl_only modules in let excluded_modules = Module_name.Set.of_list excluded_modules in { obj_dir; modules; top_sorted_modules; ext_obj; excluded_modules } ;; diff --git a/src/dune_rules/cm_files.mli b/src/dune_rules/cm_files.mli index be3cc69b33d..c685d2d0aa8 100644 --- a/src/dune_rules/cm_files.mli +++ b/src/dune_rules/cm_files.mli @@ -9,7 +9,7 @@ type t val make : ?excluded_modules:Module_name.t list -> obj_dir:Path.Build.t Obj_dir.t - -> modules:Modules.t + -> modules:Modules.With_vlib.t -> top_sorted_modules:Module.t list Action_builder.t -> ext_obj:Filename.Extension.t -> unit diff --git a/src/dune_rules/compilation_context.ml b/src/dune_rules/compilation_context.ml index 733b852eb0f..1fa0f60b1a3 100644 --- a/src/dune_rules/compilation_context.ml +++ b/src/dune_rules/compilation_context.ml @@ -59,12 +59,12 @@ let eval_opaque (ocaml : Ocaml_toolchain.t) profile = function ;; type modules = - { modules : Modules.t + { modules : Modules.With_vlib.t ; dep_graphs : Dep_graph.t Ml_kind.Dict.t } let singleton_modules m = - { modules = Modules.singleton m; dep_graphs = Dep_graph.Ml_kind.dummy m } + { modules = Modules.With_vlib.singleton m; dep_graphs = Dep_graph.Ml_kind.dummy m } ;; type t = @@ -212,7 +212,7 @@ let alias_and_root_module_flags = ;; let for_alias_module t alias_module = - let keep_flags = Modules.is_stdlib_alias (modules t) alias_module in + let keep_flags = Modules.With_vlib.is_stdlib_alias (modules t) alias_module in let flags = if keep_flags then (* in the case of stdlib, these flags can be written by the user *) @@ -232,7 +232,7 @@ let for_alias_module t alias_module = else Sandbox_config.no_special_requirements in let (modules, includes) : modules * Includes.t = - match Modules.is_stdlib_alias t.modules.modules alias_module with + match Modules.With_vlib.is_stdlib_alias t.modules.modules alias_module with | false -> singleton_modules alias_module, Includes.empty | true -> (* The stdlib alias module is different from the alias modules usually @@ -302,7 +302,7 @@ let entry_module_names sctx t = let open Memo.O in let+ modules = Dir_contents.modules_of_lib sctx t in let modules = Option.value_exn modules in - Resolve.return (Modules.entry_modules modules |> List.map ~f:Module.name) + Resolve.return (Modules.With_vlib.entry_modules modules |> List.map ~f:Module.name) ;; let root_module_entries t = diff --git a/src/dune_rules/compilation_context.mli b/src/dune_rules/compilation_context.mli index bd17fef1ad1..643466e623a 100644 --- a/src/dune_rules/compilation_context.mli +++ b/src/dune_rules/compilation_context.mli @@ -23,7 +23,7 @@ val create : super_context:Super_context.t -> scope:Scope.t -> obj_dir:Path.Build.t Obj_dir.t - -> modules:Modules.t + -> modules:Modules.With_vlib.t -> flags:Ocaml_flags.t -> requires_compile:Lib.t list Resolve.Memo.t -> requires_link:Lib.t list Resolve.t Memo.Lazy.t @@ -52,7 +52,7 @@ val scope : t -> Scope.t val dir : t -> Path.Build.t val obj_dir : t -> Path.Build.t Obj_dir.t -val modules : t -> Modules.t +val modules : t -> Modules.With_vlib.t val flags : t -> Ocaml_flags.t val requires_link : t -> Lib.t list Resolve.Memo.t val requires_compile : t -> Lib.t list Resolve.Memo.t diff --git a/src/dune_rules/context.ml b/src/dune_rules/context.ml index d62dc9a786d..b456edd62ba 100644 --- a/src/dune_rules/context.ml +++ b/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 @@ -608,7 +611,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 diff --git a/src/dune_rules/dep_rules.ml b/src/dune_rules/dep_rules.ml index f80d78e4e74..dc14d5bae97 100644 --- a/src/dune_rules/dep_rules.ml +++ b/src/dune_rules/dep_rules.ml @@ -57,14 +57,14 @@ let deps_of_module ({ modules; _ } as md) ~ml_kind m = match Module.kind m with | Wrapped_compat -> let interface_module = - match Modules.lib_interface modules with + match Modules.With_vlib.lib_interface modules with | Some m -> m - | None -> Modules.compat_for_exn modules m + | None -> Modules.With_vlib.compat_for_exn modules m in List.singleton interface_module |> Action_builder.return |> Memo.return | _ -> let+ deps = Ocamldep.deps_of md ~ml_kind m in - (match Modules.alias_for modules m with + (match Modules.With_vlib.alias_for modules m with | [] -> deps | aliases -> let open Action_builder.O in @@ -87,7 +87,7 @@ let deps_of_vlib_module ({ obj_dir; vimpl; dir; sctx; _ } as md) ~ml_kind source let+ deps = ooi_deps md ~dune_version ~vlib_obj_map ~ml_kind sourced_module in Action_builder.map deps ~f:(List.map ~f:Modules.Sourced_module.to_module) | Some lib -> - let modules = Vimpl.vlib_modules vimpl in + let modules = Vimpl.vlib_modules vimpl |> Modules.With_vlib.modules in let info = Lib.Local.info lib in let vlib_obj_dir = Lib_info.obj_dir info in let src = Obj_dir.Module.dep vlib_obj_dir (Transitive (m, ml_kind)) |> Path.build in @@ -127,16 +127,16 @@ let rec deps_of md ~ml_kind (m : Modules.Sourced_module.t) = ;; (** Tests whether a set of modules is a singleton *) -let has_single_file modules = Option.is_some @@ Modules.as_singleton modules +let has_single_file modules = Option.is_some @@ Modules.With_vlib.as_singleton modules let immediate_deps_of unit modules ~obj_dir ~ml_kind = match Module.kind unit with | Alias _ -> Action_builder.return [] | Wrapped_compat -> let interface_module = - match Modules.lib_interface modules with + match Modules.With_vlib.lib_interface modules with | Some m -> m - | None -> Modules.compat_for_exn modules unit + | None -> Modules.With_vlib.compat_for_exn modules unit in List.singleton interface_module |> Action_builder.return | _ -> @@ -155,12 +155,12 @@ let for_module md module_ = dict_of_func_concurrently (deps_of md (Normal module let rules md = let modules = md.modules in - match Modules.as_singleton modules with + match Modules.With_vlib.as_singleton modules with | Some m -> Memo.return (Dep_graph.Ml_kind.dummy m) | None -> dict_of_func_concurrently (fun ~ml_kind -> let+ per_module = - Modules.obj_map modules + Modules.With_vlib.obj_map modules |> Module_name.Unique.Parallel_map.parallel_map ~f:(fun _obj_name m -> deps_of md ~ml_kind m) in diff --git a/src/dune_rules/dep_rules.mli b/src/dune_rules/dep_rules.mli index 2f5b6bbc432..50b29419c62 100644 --- a/src/dune_rules/dep_rules.mli +++ b/src/dune_rules/dep_rules.mli @@ -9,7 +9,7 @@ val for_module val immediate_deps_of : Module.t - -> Modules.t + -> Modules.With_vlib.t -> obj_dir:Path.Build.t Obj_dir.t -> ml_kind:Ml_kind.t -> Module.t list Action_builder.t diff --git a/src/dune_rules/dialect.ml b/src/dune_rules/dialect.ml index e5f556f3fc8..56a876fadb2 100644 --- a/src/dune_rules/dialect.ml +++ b/src/dune_rules/dialect.ml @@ -11,9 +11,10 @@ module File_kind = struct ; preprocess : (Loc.t * Action.t) option ; format : (Loc.t * Action.t * string list) option ; print_ast : (Loc.t * Action.t) option + ; merlin_reader : (Loc.t * string list) option } - let encode { kind; extension; preprocess; format; print_ast } = + let encode { kind; extension; preprocess; format; print_ast; merlin_reader } = let open Dune_lang.Encoder in let kind = string @@ -33,10 +34,11 @@ module File_kind = struct "print_ast" Action.encode (Option.map ~f:(fun (_, x) -> x) print_ast) + ; field_o "merlin_reader" (list string) (Option.map ~f:snd merlin_reader) ]) ;; - let to_dyn { kind; extension; preprocess; format; print_ast } = + let to_dyn { kind; extension; preprocess; format; print_ast; merlin_reader } = let open Dyn in record [ "kind", Ml_kind.to_dyn kind @@ -44,6 +46,7 @@ module File_kind = struct ; "preprocess", option (fun (_, x) -> Action.to_dyn x) preprocess ; "format", option (fun (_, x, y) -> pair Action.to_dyn (list string) (x, y)) format ; "print_ast", option (fun (_, x) -> Action.to_dyn x) print_ast + ; "merlin_reader", option (fun (_, x) -> list string x) merlin_reader ] ;; end @@ -85,13 +88,17 @@ let decode = "format" (map ~f:(fun (loc, x) -> loc, x, []) (located Action.decode_dune_file)) and+ print_ast = field_o "print_ast" (located Action.decode_dune_file) + and+ merlin_reader = + field_o + "merlin_reader" + (Dune_lang.Syntax.since Stanza.syntax (3, 16) >>> located (repeat1 string)) and+ syntax_ver = Syntax.get_exn Stanza.syntax in let ver = 3, 9 in if syntax_ver < ver && Option.is_some (String.index_from extension 1 '.') then ( let what = "the possibility of defining extensions containing periods" in Syntax.Error.since loc Stanza.syntax ver ~what); - { File_kind.kind; extension; preprocess; format; print_ast } + { File_kind.kind; extension; preprocess; format; print_ast; merlin_reader } in fields (let+ name = field "name" string @@ -143,6 +150,13 @@ let print_ast { file_kinds; _ } ml_kind = x.print_ast ;; +let merlin_reader { file_kinds; _ } ml_kind = + let open Option.O in + let* dialect = Ml_kind.Dict.get file_kinds ml_kind in + let+ _, merlin_reader = dialect.merlin_reader in + merlin_reader +;; + let ocaml = let format kind = let flag_of_kind = function @@ -180,6 +194,7 @@ let ocaml = , format kind , [ ".ocamlformat"; ".ocamlformat-ignore"; ".ocamlformat-enable" ] ) ; print_ast = Some (Loc.none, print_ast kind) + ; merlin_reader = None } in let intf = Some (file_kind Ml_kind.Intf ".mli") in @@ -222,6 +237,7 @@ let reason = ; preprocess = Some (Loc.none, preprocess) ; format = Some (Loc.none, format, []) ; print_ast = Some (Loc.none, print_ast) + ; merlin_reader = None } in let intf = Some (file_kind Ml_kind.Intf ".rei") in @@ -251,6 +267,7 @@ let rescript = ; preprocess = Some (Loc.none, preprocess) ; format = Some (Loc.none, format, []) ; print_ast = None + ; merlin_reader = None } in let intf = Some (file_kind Ml_kind.Intf ".resi") in @@ -271,7 +288,12 @@ module DB = struct type t = { by_name : dialect String.Map.t ; by_extension : dialect Filename.Extension.Map.t - ; mutable extensions_for_merlin : string option Ml_kind.Dict.t list option + ; for_merlin : for_merlin Lazy.t + } + + and for_merlin = + { extensions : Filename.Extension.t option Ml_kind.Dict.t list + ; readers : Filename.Extension.t list String.Map.t } let fold { by_name; _ } = String.Map.fold by_name @@ -279,35 +301,49 @@ module DB = struct let empty = { by_name = String.Map.empty ; by_extension = Filename.Extension.Map.empty - ; extensions_for_merlin = None + ; for_merlin = lazy { extensions = []; readers = String.Map.empty } } ;; - let set_extensions_for_merlin t = - let v = - fold t ~init:[] ~f:(fun d s -> - let impl = extension d Ml_kind.Impl in - let intf = extension d Ml_kind.Intf in - if (* Only include dialects with no preprocessing and skip default file - extensions *) - preprocess d Ml_kind.Impl <> None - || preprocess d Ml_kind.Intf <> None - || (impl = extension ocaml Ml_kind.Impl && intf = extension ocaml Ml_kind.Intf) - then s - else { Ml_kind.Dict.impl; intf } :: s) - |> List.sort ~compare:(Ml_kind.Dict.compare (Option.compare String.compare)) + let compute_for_merlin = + let handle_ml_kind ~dialect kind readers = + let ext = extension dialect kind in + if ext = extension ocaml kind + then (* this is standard dialect, exclude *) None, readers + else ( + match ext, merlin_reader dialect kind with + | Some ext, Some reader -> Some ext, String.Map.add_exn readers ext reader + | _ -> + if preprocess dialect kind <> None + then (* we have preprocessor defined *) None, readers + else ext, readers) in - t.extensions_for_merlin <- Some v; - v + fun by_name -> + let extensions, readers = + String.Map.fold + by_name + ~init:([], String.Map.empty) + ~f:(fun dialect (extensions, readers) -> + let impl, readers = handle_ml_kind ~dialect Ml_kind.Impl readers in + let intf, readers = handle_ml_kind ~dialect Ml_kind.Intf readers in + let extensions = + match impl, intf with + | None, None -> extensions + | _ -> { Ml_kind.Dict.impl; intf } :: extensions + in + extensions, readers) + in + let extensions = + List.sort + ~compare:(Ml_kind.Dict.compare (Option.compare String.compare)) + extensions + in + { extensions; readers } ;; - let extensions_for_merlin t = - match t.extensions_for_merlin with - | Some s -> s - | None -> set_extensions_for_merlin t - ;; + let for_merlin t = Lazy.force t.for_merlin - let add { by_name; by_extension; extensions_for_merlin = _ } ~loc dialect = + let add { by_name; by_extension; for_merlin = _ } ~loc dialect = let by_name = match String.Map.add by_name dialect.name dialect with | Ok by_name -> by_name @@ -331,7 +367,7 @@ module DB = struct let by_extension = add_ext (add_ext by_extension dialect.file_kinds.intf) dialect.file_kinds.impl in - { by_name; by_extension; extensions_for_merlin = None } + { by_name; by_extension; for_merlin = lazy (compute_for_merlin by_name) } ;; let of_list dialects = List.fold_left ~f:(add ~loc:Loc.none) ~init:empty dialects diff --git a/src/dune_rules/dialect.mli b/src/dune_rules/dialect.mli index 6cb8b7a1680..7cd9b9b0ee8 100644 --- a/src/dune_rules/dialect.mli +++ b/src/dune_rules/dialect.mli @@ -43,8 +43,14 @@ module DB : sig val find_by_name : t -> string -> dialect option val find_by_extension : t -> Filename.Extension.t -> (dialect * Ml_kind.t) option val fold : t -> init:'a -> f:(dialect -> 'a -> 'a) -> 'a - val extensions_for_merlin : t -> Filename.Extension.t option Ml_kind.Dict.t list val to_dyn : t -> Dyn.t val builtin : t val is_default : t -> bool + + type for_merlin = + { extensions : string option Ml_kind.Dict.t list + ; readers : Filename.Extension.t list String.Map.t + } + + val for_merlin : t -> for_merlin end diff --git a/src/dune_rules/dir_contents.ml b/src/dune_rules/dir_contents.ml index dfadeed3b7b..8c07e0150fc 100644 --- a/src/dune_rules/dir_contents.ml +++ b/src/dune_rules/dir_contents.ml @@ -469,7 +469,7 @@ let modules_of_lib sctx lib = | External modules -> Memo.return modules | Local -> let+ modules = modules_of_local_lib sctx (Lib.Local.of_lib_exn lib) in - Some modules + Some (Modules.With_vlib.modules modules) ;; let () = diff --git a/src/dune_rules/dir_contents.mli b/src/dune_rules/dir_contents.mli index 2aad9205add..08f2451d15e 100644 --- a/src/dune_rules/dir_contents.mli +++ b/src/dune_rules/dir_contents.mli @@ -34,7 +34,7 @@ val coq : t -> Coq_sources.t Memo.t (** Get the directory contents of the given directory. *) val get : Super_context.t -> dir:Path.Build.t -> t Memo.t -val modules_of_lib : Super_context.t -> Lib.t -> Modules.t option Memo.t +val modules_of_lib : Super_context.t -> Lib.t -> Modules.With_vlib.t option Memo.t val modules_of_local_lib : Super_context.t -> Lib.Local.t -> Modules.t Memo.t (** All directories in this group if [t] is a group root or just [t] if it is diff --git a/src/dune_rules/dune_package.ml b/src/dune_rules/dune_package.ml index 50937ebd1e8..d14728342ba 100644 --- a/src/dune_rules/dune_package.ml +++ b/src/dune_rules/dune_package.ml @@ -144,7 +144,7 @@ module Lib = struct ; field_o "main_module_name" Module_name.encode main_module_name ; field_l "modes" sexp (Lib_mode.Map.Set.encode modes) ; field_l "obj_dir" sexp (Obj_dir.encode obj_dir) - ; field_o "modules" (Modules.encode ~src_dir:package_root) modules + ; field_o "modules" (Modules.With_vlib.encode ~src_dir:package_root) modules ; paths "melange_runtime_deps" melange_runtime_deps ; field_o "special_builtin_support" @@ -228,7 +228,6 @@ module Lib = struct field_o "instrumentation.backend" (located Lib_name.decode) in let modes = Lib_mode.Map.Set.of_list modes in - let entry_modules = Modules.entry_modules modules |> List.map ~f:Module.name in let info : Path.t Lib_info.t = let src_dir = Obj_dir.dir obj_dir in let lib_id = Lib_id.External (loc, name) in @@ -248,7 +247,13 @@ module Lib = struct let virtual_ = if virtual_ then Some (Lib_info.Source.External modules) else None in - let wrapped = Some (Lib_info.Inherited.This (Modules.wrapped modules)) in + let modules = Modules.With_vlib.modules modules in + let entry_modules = + Modules.With_vlib.entry_modules modules |> List.map ~f:Module.name + in + let wrapped = + Some (Lib_info.Inherited.This (Modules.With_vlib.wrapped modules)) + in let entry_modules = Lib_info.Source.External (Ok entry_modules) in let modules = Lib_info.Source.External (Some modules) in let melange_runtime_deps = Lib_info.File_deps.External melange_runtime_deps in @@ -309,7 +314,7 @@ module Lib = struct let wrapped t = match Lib_info.modules t.info with - | External modules -> Option.map modules ~f:Modules.wrapped + | External modules -> Option.map modules ~f:Modules.With_vlib.wrapped | Local -> None ;; diff --git a/src/dune_rules/exe.ml b/src/dune_rules/exe.ml index dbd1f10f7a2..c29612cc599 100644 --- a/src/dune_rules/exe.ml +++ b/src/dune_rules/exe.ml @@ -278,13 +278,13 @@ let link_many Memo.parallel_map programs ~f:(fun { Program.name; main_module_name; loc } -> let top_sorted_modules = let main = - match Modules.find modules main_module_name with + match Modules.With_vlib.find modules main_module_name with | Some m -> m | None -> Code_error.raise "link_many: unable to find module" [ "main_module_name", Module_name.to_dyn main_module_name - ; "modules", Modules.to_dyn modules + ; "modules", Modules.With_vlib.to_dyn modules ] in Dep_graph.top_closed_implementations diff --git a/src/dune_rules/exe_rules.ml b/src/dune_rules/exe_rules.ml index 875b00e131a..536ee728ab9 100644 --- a/src/dune_rules/exe_rules.ml +++ b/src/dune_rules/exe_rules.ml @@ -45,7 +45,7 @@ let linkages let programs ~modules ~(exes : Executables.t) = List.map (Nonempty_list.to_list exes.names) ~f:(fun (loc, name) -> let mod_name = Module_name.of_string_allow_invalid (loc, name) in - match Modules.find modules mod_name with + match Modules.With_vlib.find modules mod_name with | Some m -> if Module.has m ~ml_kind:Impl then { Exe.Program.name; main_module_name = mod_name; loc } @@ -133,7 +133,6 @@ let executables_rules let ctx = Super_context.context sctx in let* ocaml = Context.ocaml ctx in let project = Scope.project scope in - let programs = programs ~modules ~exes in let explicit_js_mode = Dune_project.explicit_js_mode project in let* linkages = let+ dynamically_linked_foreign_archives = @@ -143,14 +142,18 @@ let executables_rules in let* flags = Buildable_rules.ocaml_flags sctx ~dir exes.buildable.flags in let* modules, pp = - Buildable_rules.modules_rules - sctx - (Executables (exes.buildable, Nonempty_list.to_list exes.names)) - expander - ~dir - scope - modules + let+ modules, pp = + Buildable_rules.modules_rules + sctx + (Executables (exes.buildable, Nonempty_list.to_list exes.names)) + expander + ~dir + scope + modules + in + Modules.With_vlib.modules modules, pp in + let programs = programs ~modules ~exes in let* cctx = let requires_compile = Lib.Compile.direct_requires compile_info in let requires_link = Lib.Compile.requires_link compile_info in diff --git a/src/dune_rules/fetch_rules.ml b/src/dune_rules/fetch_rules.ml index 885e19c22b6..823a1024abd 100644 --- a/src/dune_rules/fetch_rules.ml +++ b/src/dune_rules/fetch_rules.ml @@ -41,8 +41,8 @@ let resolve_url = Memo.of_reproducible_fiber @@ let open Fiber.O in - let* rev_store = Rev_store.get in let+ git_object = + let* rev_store = Rev_store.get in OpamUrl.resolve url ~loc:Loc.none rev_store >>| function | Ok (Resolved r) -> (r :> Rev_store.Object.t) @@ -146,8 +146,8 @@ let extract_checksums_and_urls (lockdir : Dune_pkg.Lock_dir.t) = lockdir.packages ~init:(Checksum.Map.empty, Dune_digest.Map.empty) ~f:(fun package acc -> - let sources = package.info.extra_sources |> List.rev_map ~f:snd in let sources = + let sources = package.info.extra_sources |> List.rev_map ~f:snd in match package.info.source with | None -> sources | Some source -> source :: sources @@ -316,20 +316,21 @@ module Copy = struct ;; end -let deps kind url_or_checksum = - let src = make_target ~kind url_or_checksum in - Path.build src |> Dep.file |> Action_builder.dep |> Action_builder.with_no_targets -;; - let fetch ~target kind url checksum = - let url_or_checksum = - match checksum with - | Some (_, checksum) -> `Checksum checksum - | None -> `Url (snd url) + let src = + let url_or_checksum = + match checksum with + | Some (_, checksum) -> `Checksum checksum + | None -> `Url (snd url) + in + Path.build (make_target ~kind url_or_checksum) in - let src = Path.build (make_target ~kind url_or_checksum) in let open Action_builder.With_targets.O in - deps kind url_or_checksum + (* [Action_builder.copy] already adds this dependency for us, + so this is only useful for the [`Directory] clause *) + Dep.file src + |> Action_builder.dep + |> Action_builder.with_no_targets >>> match kind with | `File -> Action_builder.copy ~src ~dst:target diff --git a/src/dune_rules/inline_tests.ml b/src/dune_rules/inline_tests.ml index d104be33548..8ee8ba68904 100644 --- a/src/dune_rules/inline_tests.ml +++ b/src/dune_rules/inline_tests.ml @@ -94,7 +94,7 @@ include Sub_system.Register_end_point (struct Module.generated ~kind:Impl ~src_dir:inline_test_dir [ name ] in let open Memo.O in - let modules = Modules.singleton_exe main_module in + let modules = Modules.With_vlib.singleton_exe main_module in let runner_libs = let open Resolve.Memo.O in let* libs = diff --git a/src/dune_rules/install_rules.ml b/src/dune_rules/install_rules.ml index 43163066872..9eac49b5ad6 100644 --- a/src/dune_rules/install_rules.ml +++ b/src/dune_rules/install_rules.ml @@ -94,6 +94,7 @@ end = struct ml_sources ~libs:(Scope.libs scope) ~for_:(Library (Lib_info.lib_id lib |> Lib_id.to_local_exn)) + >>| Modules.With_vlib.modules >>| Option.some and+ foreign_archives = match Lib_info.virtual_ lib with @@ -192,7 +193,7 @@ end = struct ~libs:(Scope.libs scope) ~for_:(Library (Lib_info.lib_id info |> Lib_id.to_local_exn)) and+ impl = Virtual_rules.impl sctx ~lib ~scope in - Vimpl.impl_modules impl modules |> Modules.split_by_lib + Vimpl.impl_modules impl modules |> Modules.With_vlib.split_by_lib in let lib_src_dir = Lib_info.src_dir info in let sources = @@ -674,6 +675,7 @@ end = struct >>= Ml_sources.modules ~libs ~for_:(Library (Lib_info.lib_id info |> Lib_id.to_local_exn)) + >>| Modules.With_vlib.modules and* melange_runtime_deps = file_deps (Lib_info.melange_runtime_deps info) and* public_headers = file_deps (Lib_info.public_headers info) in let+ dune_lib = diff --git a/src/dune_rules/lib.ml b/src/dune_rules/lib.ml index 354bd88906f..5d24a319485 100644 --- a/src/dune_rules/lib.ml +++ b/src/dune_rules/lib.ml @@ -2156,7 +2156,10 @@ let to_dune_lib in let modules = let install_dir = Obj_dir.dir obj_dir in - Modules.version_installed modules ~src_root:(Lib_info.src_dir lib.info) ~install_dir + Modules.With_vlib.version_installed + modules + ~src_root:(Lib_info.src_dir lib.info) + ~install_dir in let use_public_name ~lib_field ~info_field = match info_field, lib_field with diff --git a/src/dune_rules/lib.mli b/src/dune_rules/lib.mli index 5baa861f20b..4952c57067e 100644 --- a/src/dune_rules/lib.mli +++ b/src/dune_rules/lib.mli @@ -212,7 +212,7 @@ end val to_dune_lib : t - -> modules:Modules.t + -> modules:Modules.With_vlib.t -> foreign_objects:Path.t list -> melange_runtime_deps:Path.t list -> public_headers:Path.t list diff --git a/src/dune_rules/lib_info.ml b/src/dune_rules/lib_info.ml index a06610a72b3..32a89a883f8 100644 --- a/src/dune_rules/lib_info.ml +++ b/src/dune_rules/lib_info.ml @@ -330,7 +330,7 @@ type 'path t = ; wrapped : Wrapped.t Inherited.t option ; main_module_name : Main_module_name.t ; modes : Lib_mode.Map.Set.t - ; modules : Modules.t option Source.t + ; modules : Modules.With_vlib.t option Source.t ; special_builtin_support : (Loc.t * Special_builtin_support.t) option ; exit_module : Module_name.t option ; instrumentation_backend : (Loc.t * Lib_name.t) option @@ -381,7 +381,8 @@ let eval_native_archives_exn (type path) (t : path t) ~modules = match t.native_archives, modules with | Files f, _ -> f | Needs_module_info _, None -> Code_error.raise "missing module information" [] - | Needs_module_info f, Some modules -> if Modules.has_impl modules then [ f ] else [] + | Needs_module_info f, Some modules -> + if Modules.With_vlib.has_impl modules then [ f ] else [] ;; let user_written_deps t = @@ -597,7 +598,7 @@ let to_dyn ; "wrapped", option (Inherited.to_dyn Wrapped.to_dyn) wrapped ; "main_module_name", Main_module_name.to_dyn main_module_name ; "modes", Lib_mode.Map.Set.to_dyn modes - ; "modules", Source.to_dyn (Dyn.option Modules.to_dyn) modules + ; "modules", Source.to_dyn (Dyn.option Modules.With_vlib.to_dyn) modules ; ( "special_builtin_support" , option (snd Special_builtin_support.to_dyn) special_builtin_support ) ; "exit_module", option Module_name.to_dyn exit_module diff --git a/src/dune_rules/lib_info.mli b/src/dune_rules/lib_info.mli index f0e69642a01..41ea767962a 100644 --- a/src/dune_rules/lib_info.mli +++ b/src/dune_rules/lib_info.mli @@ -115,7 +115,7 @@ val native_archives : 'path t -> 'path native_archives (** [eval_native_archives] is like [native_archives] but it knows how to evaluate [Needs_module_info] into the list of archives *) -val eval_native_archives_exn : 'path t -> modules:Modules.t option -> 'path list +val eval_native_archives_exn : 'path t -> modules:Modules.With_vlib.t option -> 'path list (** [dll*.so] files for stubs. These are read when linking a bytecode executable and are loaded dynamically at runtime by bytecode executables. *) @@ -144,7 +144,7 @@ val main_module_name : _ t -> Main_module_name.t val wrapped : _ t -> Wrapped.t Inherited.t option val special_builtin_support : _ t -> (Loc.t * Special_builtin_support.t) option val modes : _ t -> Lib_mode.Map.Set.t -val modules : _ t -> Modules.t option Source.t +val modules : _ t -> Modules.With_vlib.t option Source.t val implements : _ t -> (Loc.t * Lib_name.t) option val requires : _ t -> Lib_dep.t list val ppx_runtime_deps : _ t -> (Loc.t * Lib_name.t) list @@ -179,7 +179,7 @@ val for_dune_package -> sub_systems:Sub_system_info.t Sub_system_name.Map.t -> melange_runtime_deps:Path.t list -> public_headers:Path.t list - -> modules:Modules.t + -> modules:Modules.With_vlib.t -> Path.t t val map_path : Path.t t -> f:(Path.t -> Path.t) -> Path.t t @@ -221,7 +221,7 @@ val create -> implements:(Loc.t * Lib_name.t) option -> default_implementation:(Loc.t * Lib_name.t) option -> modes:Lib_mode.Map.Set.t - -> modules:Modules.t option Source.t + -> modules:Modules.With_vlib.t option Source.t -> wrapped:Wrapped.t Inherited.t option -> special_builtin_support:(Loc.t * Special_builtin_support.t) option -> exit_module:Module_name.t option diff --git a/src/dune_rules/lib_rules.ml b/src/dune_rules/lib_rules.ml index 395455fc2b7..82f729dd807 100644 --- a/src/dune_rules/lib_rules.ml +++ b/src/dune_rules/lib_rules.ml @@ -120,10 +120,10 @@ let build_lib let gen_wrapped_compat_modules (lib : Library.t) cctx = let modules = Compilation_context.modules cctx in - let wrapped_compat = Modules.wrapped_compat modules in + let wrapped_compat = Modules.With_vlib.wrapped_compat modules in let transition_message = lazy - (match Modules.wrapped modules with + (match Modules.With_vlib.wrapped modules with | Simple _ -> assert false | Yes_with_transition r -> r) in @@ -439,7 +439,7 @@ let setup_build_archives (lib : Library.t) ~top_sorted_modules ~cctx ~expander ~ let { Lib_config.ext_obj; natdynlink_supported; _ } = ocaml.lib_config in let open Memo.O in let* () = - Modules.exit_module modules + Modules.With_vlib.exit_module modules |> Memo.Option.iter ~f:(fun m -> (* These files needs to be alongside stdlib.cma as the compiler implicitly adds this module. *) @@ -581,7 +581,7 @@ let library_rules let ocaml = Compilation_context.ocaml cctx in let stdlib_dir = ocaml.lib_config.stdlib_dir in let top_sorted_modules = - let impl_only = Modules.impl_only modules in + let impl_only = Modules.With_vlib.impl_only modules in Dep_graph.top_closed_implementations (Compilation_context.dep_graphs cctx).impl impl_only diff --git a/src/dune_rules/link_time_code_gen.ml b/src/dune_rules/link_time_code_gen.ml index 19a6892e926..bedf62744f6 100644 --- a/src/dune_rules/link_time_code_gen.ml +++ b/src/dune_rules/link_time_code_gen.ml @@ -16,7 +16,7 @@ let generate_and_compile_module cctx ~precompiled_cmi ~obj_name ~name ~lib ~code | Some _ -> obj_name | None -> Option.map modules ~f:(fun modules -> - Modules.find modules name |> Option.value_exn |> Module.obj_name) + Modules.With_vlib.find modules name |> Option.value_exn |> Module.obj_name) in let src_dir = let obj_dir = Compilation_context.obj_dir cctx in diff --git a/src/dune_rules/mdx.ml b/src/dune_rules/mdx.ml index b6a3eca186c..810f0426d93 100644 --- a/src/dune_rules/mdx.ml +++ b/src/dune_rules/mdx.ml @@ -475,7 +475,7 @@ let mdx_prog_gen t ~sctx ~dir ~scope ~mdx_prog = let obj_dir = Obj_dir.make_exe ~dir ~name in let modules = Module.generated ~kind:Impl ~src_dir:dir [ main_module_name ] - |> Modules.singleton_exe + |> Modules.With_vlib.singleton_exe in let flags = Ocaml_flags.default ~dune_version ~profile:Release in Compilation_context.create diff --git a/src/dune_rules/melange/melange_rules.ml b/src/dune_rules/melange/melange_rules.ml index 2dd06096149..8756671ed3f 100644 --- a/src/dune_rules/melange/melange_rules.ml +++ b/src/dune_rules/melange/melange_rules.ml @@ -62,9 +62,8 @@ let modules_in_obj_dir ~sctx ~scope ~preprocess modules = ;; let impl_only_modules_defined_in_this_lib ~sctx ~scope lib = - let* modules = Dir_contents.modules_of_lib sctx lib in - match modules with - | None -> + match Lib_info.modules (Lib.info lib) with + | External None -> User_error.raise [ Pp.textf "The library %s was not compiled with Dune or it was compiled with Dune but \ @@ -72,11 +71,18 @@ let impl_only_modules_defined_in_this_lib ~sctx ~scope lib = melange support" (Lib.name lib |> Lib_name.to_string) ] - | Some modules -> - let info = Lib.info lib in + | External (Some modules) -> + Memo.return + ( modules + , (Modules.With_vlib.split_by_lib modules).impl + |> List.filter ~f:(Module.has ~ml_kind:Impl) ) + | Local -> + let lib = Lib.Local.of_lib_exn lib in + let info = Lib.Local.info lib in let+ modules = + let* modules = Dir_contents.modules_of_local_lib sctx lib in let preprocess = Lib_info.preprocess info in - modules_in_obj_dir ~sctx ~scope ~preprocess modules + modules_in_obj_dir ~sctx ~scope ~preprocess modules >>| Modules.With_vlib.modules in let () = let modes = Lib_info.modes info in @@ -95,8 +101,8 @@ let impl_only_modules_defined_in_this_lib ~sctx ~scope lib = | true -> () in ( modules - , (* for a virtual library, this will return all modules *) - (Modules.split_by_lib modules).impl |> List.filter ~f:(Module.has ~ml_kind:Impl) ) + , (Modules.With_vlib.split_by_lib modules).impl + |> List.filter ~f:(Module.has ~ml_kind:Impl) ) ;; let cmj_glob = Glob.of_string_exn Loc.none "*.cmj" @@ -151,7 +157,9 @@ let compile_info ~scope (mel : Melange_stanzas.Emit.t) = let js_targets_of_modules modules ~module_systems ~output = List.map module_systems ~f:(fun (_, js_ext) -> - Modules.fold_no_vlib modules ~init:Path.Set.empty ~f:(fun m acc -> + modules + |> Modules.With_vlib.drop_vlib + |> Modules.fold ~init:Path.Set.empty ~f:(fun m acc -> if Module.has m ~ml_kind:Impl then ( let target = Path.build @@ make_js_name ~js_ext ~output m in @@ -272,20 +280,23 @@ let setup_emit_cmj_rules in let* () = Check_rules.add_obj_dir sctx ~obj_dir Melange in let* modules, pp = - Buildable_rules.modules_rules - sctx - (Melange - { preprocess = mel.preprocess - ; preprocessor_deps = mel.preprocessor_deps - ; (* TODO still needed *) - lint = Preprocess.Per_module.default () - ; (* why is this always false? *) - empty_module_interface_if_absent = false - }) - expander - ~dir - scope - modules + let+ modules, pp = + Buildable_rules.modules_rules + sctx + (Melange + { preprocess = mel.preprocess + ; preprocessor_deps = mel.preprocessor_deps + ; (* TODO still needed *) + lint = Preprocess.Per_module.default () + ; (* why is this always false? *) + empty_module_interface_if_absent = false + }) + expander + ~dir + scope + modules + in + Modules.With_vlib.modules modules, pp in let requires_link = Lib.Compile.requires_link compile_info in let* flags = @@ -434,7 +445,7 @@ let modules_for_js_and_obj_dir ~sctx ~dir_contents ~scope (mel : Melange_stanzas in let+ modules = modules_in_obj_dir ~sctx ~scope ~preprocess:mel.preprocess modules in let modules_for_js = - Modules.fold_no_vlib modules ~init:[] ~f:(fun x acc -> + Modules.fold modules ~init:[] ~f:(fun x acc -> if Module.has x ~ml_kind:Impl then x :: acc else acc) in modules, modules_for_js, obj_dir @@ -464,8 +475,10 @@ let setup_entries_js let* () = setup_runtime_assets_rules sctx ~dir ~target_dir ~mode ~output ~for_:`Emit mel in + let local_modules_and_obj_dir = + Some (Modules.With_vlib.modules local_modules, local_obj_dir) + in Memo.parallel_iter modules_for_js ~f:(fun m -> - let local_modules_and_obj_dir = Some (local_modules, local_obj_dir) in build_js ~dir ~loc @@ -487,14 +500,14 @@ let setup_js_rules_libraries = let obj_dir = Lib.Local.obj_dir lib in modules, obj_dir) in - let parallel_build_source_modules ~sctx ~scope ~f lib = + let parallel_build_source_modules ~sctx ~scope ~f:build_js lib = let* local_modules_and_obj_dir, source_modules = let+ lib_modules, source_modules = impl_only_modules_defined_in_this_lib ~sctx ~scope lib in local_modules_and_obj_dir ~lib lib_modules, source_modules in - Memo.parallel_iter source_modules ~f:(f ~local_modules_and_obj_dir) + Memo.parallel_iter source_modules ~f:(build_js ~local_modules_and_obj_dir) in fun ~dir ~scope ~target_dir ~sctx ~requires_link ~mode (mel : Melange_stanzas.Emit.t) -> let build_js = build_js ~sctx ~mode ~module_systems:mel.module_systems in @@ -642,7 +655,7 @@ let setup_emit_js_rules ~dir_contents ~dir ~scope ~sctx mel = package). When resolution fails, we replace the JS entries with the resolution error inside [Action_builder.fail] to give Dune a chance to fail if any of the targets end up attached to a package installation. *) - let* _local_modules, modules_for_js, _obj_dir = + let* _, modules_for_js, _obj_dir = modules_for_js_and_obj_dir ~sctx ~dir_contents ~scope mel in let module_systems = mel.module_systems in diff --git a/src/dune_rules/merlin/merlin.ml b/src/dune_rules/merlin/merlin.ml index a6bf78871db..fa70393ae8e 100644 --- a/src/dune_rules/merlin/merlin.ml +++ b/src/dune_rules/merlin/merlin.ml @@ -68,25 +68,30 @@ module Processed = struct type module_config = { opens : Module_name.t list ; module_ : Module.t + ; reader : string list option } - let dyn_of_module_config { opens; module_ } = + let dyn_of_module_config { opens; module_; reader } = let open Dyn in - record [ "opens", list Module_name.to_dyn opens; "module_", Module.to_dyn module_ ] + record + [ "opens", list Module_name.to_dyn opens + ; "module_", Module.to_dyn module_ + ; "reader", option (list string) reader + ] ;; (* ...but modules can have different preprocessing specifications*) type t = { config : config - ; per_module_config : module_config Path.Build.Map.t + ; per_file_config : module_config Path.Build.Map.t ; pp_config : pp_flag option Module_name.Per_item.t } - let to_dyn { config; per_module_config; pp_config } = + let to_dyn { config; per_file_config; pp_config } = let open Dyn in record [ "config", dyn_of_config config - ; "per_module_config", Path.Build.Map.to_dyn dyn_of_module_config per_module_config + ; "per_file_config", Path.Build.Map.to_dyn dyn_of_module_config per_file_config ; "pp_config", Module_name.Per_item.to_dyn (option dyn_of_pp_flag) pp_config ] ;; @@ -106,7 +111,7 @@ module Processed = struct ; flags = [ "-x" ] ; extensions = [ { Ml_kind.Dict.intf = None; impl = Some "ext" } ] } - ; per_module_config = Path.Build.Map.empty + ; per_file_config = Path.Build.Map.empty ; pp_config = (match Module_name.Per_item.of_mapping @@ -144,7 +149,7 @@ module Processed = struct | None, None -> None ;; - let to_sexp ~opens ~pp { stdlib_dir; obj_dirs; src_dirs; flags; extensions } = + let to_sexp ~opens ~pp ~reader { stdlib_dir; obj_dirs; 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)) @@ -185,8 +190,16 @@ module Processed = struct let+ impl, intf = get_ext x in make_directive "SUFFIX" (Sexp.Atom (Printf.sprintf "%s %s" impl intf))) in + let reader = + match reader with + | Some reader -> + [ make_directive "READER" (Sexp.List (List.map ~f:(fun r -> Sexp.Atom r) reader)) + ] + | None -> [] + in Sexp.List - (List.concat [ stdlib_dir; exclude_query_dir; obj_dirs; src_dirs; flags; suffixes ]) + (List.concat + [ stdlib_dir; exclude_query_dir; obj_dirs; src_dirs; flags; suffixes; reader ]) ;; let quote_for_dot_merlin s = @@ -231,39 +244,46 @@ module Processed = struct Buffer.contents b ;; - let get { per_module_config; pp_config; config } ~file = - (* We only match the first part of the filename : foo.ml -> foo foo.cppo.ml - -> foo *) + let get { per_file_config; pp_config; config } ~file = let open Option.O in - let+ { module_; opens } = - let find file = - let file_without_ext = remove_extension file in - Path.Build.Map.find per_module_config file_without_ext - in + let+ { module_; opens; reader } = + let find file = Path.Build.Map.find per_file_config file in match find file with | Some _ as s -> s - | None -> Copy_line_directive.DB.follow_while file ~f:find + | None -> + (match Copy_line_directive.DB.follow_while file ~f:find with + | Some _ as s -> s + | None -> + (* Fallback to handle preprocessed files (where the preprocessor has + the file extensison changed). + + We choose to fallback by a lookup by filename without extension. + + This is too rough but, really, preprocessors should emit copy + line directives instead and then Dune should have the database + similar to Copy_line_directive to handle this. *) + Path.Build.Map.find per_file_config (remove_extension file)) in let pp = Module_name.Per_item.get pp_config (Module.name module_) in - to_sexp ~opens ~pp config + to_sexp ~opens ~pp ~reader config ;; let print_file path = match load_file path with | Error msg -> Printf.eprintf "%s\n" msg - | Ok { per_module_config; pp_config; config } -> - let pp_one (source, { module_; opens }) = + | Ok { per_file_config; pp_config; config } -> + let pp_one (source, { module_; opens; reader }) = let open Pp.O in let name = Module.name module_ in let pp = Module_name.Per_item.get pp_config name in - let sexp = to_sexp ~opens ~pp config in + let sexp = to_sexp ~reader ~opens ~pp config in Pp.hvbox (Pp.textf "%s: %s" (Module_name.to_string name) (Path.Build.to_string source)) ++ Pp.newline ++ Pp.vbox (Sexp.pp sexp) in let pp = - Path.Build.Map.to_list per_module_config + Path.Build.Map.to_list per_file_config |> Pp.concat_map ~sep:Pp.cut ~f:pp_one |> Pp.vbox in @@ -288,7 +308,7 @@ module Processed = struct ~f: (fun (acc_pp, acc_obj, acc_src, acc_flags, acc_ext) - { per_module_config = _ + { per_file_config = _ ; pp_config ; config = { stdlib_dir = _; obj_dirs; src_dirs; flags; extensions } } @@ -335,13 +355,14 @@ module Unprocessed = struct ; source_dirs : Path.Source.Set.t ; objs_dirs : Path.Set.t ; extensions : string option Ml_kind.Dict.t list + ; readers : string list String.Map.t ; mode : Lib_mode.t } type t = { ident : Merlin_ident.t ; config : config - ; modules : Modules.t + ; modules : Modules.With_vlib.t } let make @@ -373,7 +394,7 @@ module Unprocessed = struct Path.Set.singleton @@ obj_dir_of_lib `Private mode (Obj_dir.of_local obj_dir) in let flags = Ocaml_flags.get flags mode in - let extensions = Dialect.DB.extensions_for_merlin dialects in + let { Dialect.DB.extensions; readers } = Dialect.DB.for_merlin dialects in let config = { stdlib_dir ; mode @@ -384,6 +405,7 @@ module Unprocessed = struct ; source_dirs ; objs_dirs ; extensions + ; readers } in { ident; config; modules } @@ -465,11 +487,10 @@ module Unprocessed = struct ;; let src_dirs sctx lib = - match Lib.is_local lib with - | false -> Lib.info lib |> Lib_info.src_dir |> Path.Set.singleton |> Memo.return - | true -> - Dir_contents.modules_of_lib sctx lib - >>| Option.value_exn + match Lib.Local.of_lib lib with + | None -> Lib.info lib |> Lib_info.src_dir |> Path.Set.singleton |> Memo.return + | Some lib -> + Dir_contents.modules_of_local_lib sctx lib >>| Modules.source_dirs >>| Path.Set.map ~f:Path.drop_optional_build_context ;; @@ -489,6 +510,7 @@ module Unprocessed = struct ; config = { stdlib_dir ; extensions + ; readers ; flags ; objs_dirs ; source_dirs @@ -563,22 +585,27 @@ module Unprocessed = struct in { Processed.stdlib_dir; src_dirs; obj_dirs; flags; extensions } and+ pp_config = pp_config t (Super_context.context sctx) ~expander in - let per_module_config = + let per_file_config = (* And copy for each module the resulting pp flags *) - Modules.fold_no_vlib modules ~init:[] ~f:(fun m init -> - Module.sources m - |> Path.Build.Set.of_list_map ~f:(fun src -> - Path.as_in_build_dir_exn src |> remove_extension) + modules + |> Modules.With_vlib.drop_vlib + |> Modules.fold ~init:[] ~f:(fun m init -> + Module.sources_without_pp m + |> Path.Build.Set.of_list_map ~f:(fun src -> Path.as_in_build_dir_exn src) |> Path.Build.Set.fold ~init ~f:(fun src acc -> let config = { Processed.module_ = Module.set_pp m None - ; opens = Modules.local_open modules m + ; opens = Modules.With_vlib.local_open modules m + ; reader = String.Map.find readers (Path.Build.extension src) } in - (src, config) :: acc)) - |> Path.Build.Map.of_list_exn + (* we add the config with and without the extension, the latter is + needed for a fallback in this file's [get] function. *) + let src_without_extension = remove_extension src in + (src, config) :: (src_without_extension, config) :: acc)) + |> Path.Build.Map.of_list_reduce ~f:(fun existing _ -> existing) in - { Processed.pp_config; config; per_module_config } + { Processed.pp_config; config; per_file_config } ;; end diff --git a/src/dune_rules/merlin/merlin.mli b/src/dune_rules/merlin/merlin.mli index 84f352ed366..57f92caa22c 100644 --- a/src/dune_rules/merlin/merlin.mli +++ b/src/dune_rules/merlin/merlin.mli @@ -47,7 +47,7 @@ val make -> preprocess:Preprocess.Without_instrumentation.t Preprocess.t Module_name.Per_item.t -> libname:Lib_name.Local.t option -> source_dirs:Path.Source.Set.t - -> modules:Modules.t + -> modules:Modules.With_vlib.t -> obj_dir:Path.Build.t Obj_dir.t -> dialects:Dialect.DB.t -> ident:Merlin_ident.t diff --git a/src/dune_rules/ml_sources.ml b/src/dune_rules/ml_sources.ml index 520f2f5c03f..00b2276732f 100644 --- a/src/dune_rules/ml_sources.ml +++ b/src/dune_rules/ml_sources.ml @@ -28,7 +28,7 @@ module Origin = struct end module Modules = struct - type component = Origin.t * Modules.t * Path.Build.t Obj_dir.t + type component = Origin.t * Modules_group.t * Path.Build.t Obj_dir.t type t = { libraries : component Lib_id.Local.Map.t diff --git a/src/dune_rules/module.ml b/src/dune_rules/module.ml index 21d5053f86b..6ea97e25ad9 100644 --- a/src/dune_rules/module.ml +++ b/src/dune_rules/module.ml @@ -3,6 +3,9 @@ open Import module File = struct type t = { path : Path.t + ; original_path : Path.t + (* while path can be changed for a module (when it is being pp'ed), the + original_path stays the same and points to an original source file *) ; dialect : Dialect.t } @@ -11,16 +14,17 @@ module File = struct fields @@ let+ path = field "path" (Dune_lang.Path.Local.decode ~dir) in (* TODO do not just assume the dialect is OCaml *) - { path; dialect = Dialect.ocaml } + { path; original_path = path; dialect = Dialect.ocaml } ;; - let encode { path; dialect = _ } ~dir = + let encode { path; original_path = _; dialect = _ } ~dir = let open Dune_lang.Encoder in record_fields [ field "path" (Dune_lang.Path.Local.encode ~dir) path ] ;; let dialect t = t.dialect let path t = t.path + let original_path t = t.original_path let version_installed t ~src_root ~install_dir = let path = @@ -32,11 +36,15 @@ module File = struct { t with path } ;; - let make dialect path = { dialect; path } + let make dialect path = { dialect; path; original_path = path } - let to_dyn { path; dialect } = + let to_dyn { path; original_path; dialect } = let open Dyn in - record [ "path", Path.to_dyn path; "dialect", Dyn.string @@ Dialect.name dialect ] + record + [ "path", Path.to_dyn path + ; "original_path", Path.to_dyn original_path + ; "dialect", Dyn.string @@ Dialect.name dialect + ] ;; end @@ -305,17 +313,17 @@ let wrapped_compat t = assert (t.visibility = Public); let source = let impl = - Some - { File.dialect = Dialect.ocaml - ; path = - (* Option.value_exn cannot fail because we disallow wrapped - compatibility mode for virtual libraries. That means none of the - modules are implementing a virtual module, and therefore all have - a source dir *) - Path.L.relative - (src_dir t) - [ ".wrapped_compat"; Module_name.Path.to_string t.source.path ^ ml_gen ] - } + let path = + (* TODO(andreypopp): is this comment still relevant? *) + (* Option.value_exn cannot fail because we disallow wrapped + compatibility mode for virtual libraries. That means none of the + modules are implementing a virtual module, and therefore all have + a source dir *) + Path.L.relative + (src_dir t) + [ ".wrapped_compat"; Module_name.Path.to_string t.source.path ^ ml_gen ] + in + Some { File.dialect = Dialect.ocaml; path; original_path = path } in { t.source with files = { intf = None; impl } } in @@ -330,6 +338,12 @@ let sources t = ~f:(Option.map ~f:(fun (x : File.t) -> x.path)) ;; +let sources_without_pp t = + List.filter_map + [ t.source.files.intf; t.source.files.impl ] + ~f:(Option.map ~f:(fun (x : File.t) -> x.original_path)) +;; + module Obj_map = struct include Map.Make (struct type nonrec t = t @@ -387,7 +401,7 @@ let ml_source = | None -> f | Some suffix -> let path = Path.extend_basename f.path ~suffix in - File.make Dialect.ocaml path) + { f with dialect = Dialect.ocaml; path }) ;; let version_installed t ~src_root ~install_dir = diff --git a/src/dune_rules/module.mli b/src/dune_rules/module.mli index 7788038b68d..4e54bd91461 100644 --- a/src/dune_rules/module.mli +++ b/src/dune_rules/module.mli @@ -7,6 +7,7 @@ module File : sig val dialect : t -> Dialect.t val path : t -> Path.t + val original_path : t -> Path.t val make : Dialect.t -> Path.t -> t end @@ -61,7 +62,6 @@ val set_obj_name : t -> Module_name.Unique.t -> t val set_path : t -> Module_name.Path.t -> t val add_file : t -> Ml_kind.t -> File.t -> t val set_source : t -> Ml_kind.t -> File.t option -> t -val map_files : t -> f:(Ml_kind.t -> File.t -> File.t) -> t (** Set preprocessing flags *) val set_pp : t -> (string list Action_builder.t * Sandbox_config.t) option -> t @@ -88,6 +88,7 @@ module Obj_map : sig end val sources : t -> Path.t list +val sources_without_pp : t -> Path.t list val visibility : t -> Visibility.t val encode : t -> src_dir:Path.t -> Dune_lang.t list val decode : src_dir:Path.t -> t Dune_lang.Decoder.t diff --git a/src/dune_rules/module_compilation.ml b/src/dune_rules/module_compilation.ml index a6adb6cb113..6b5f82150c6 100644 --- a/src/dune_rules/module_compilation.ml +++ b/src/dune_rules/module_compilation.ml @@ -14,7 +14,7 @@ let force_read_cmi source_file = [ "-intf-suffix"; Path.extension source_file ] generation *) let opens modules m = - Command.Args.As (Modules.local_open modules m |> Ocaml_flags.open_flags) + Command.Args.As (Modules.With_vlib.local_open modules m |> Ocaml_flags.open_flags) ;; let other_cm_files ~opaque ~cm_kind ~obj_dir = @@ -421,7 +421,7 @@ module Alias_module = struct let aliases = Modules.Group.for_alias group |> List.map ~f:(fun (local_name, m) -> - let canonical_path = Modules.canonical_path modules group m in + let canonical_path = Modules.With_vlib.canonical_path modules group m in let obj_name = Module.obj_name m in { canonical_path; local_name; obj_name }) in @@ -499,7 +499,7 @@ let build_all cctx = let for_wrapped_compat = lazy (Compilation_context.for_wrapped_compat cctx) in let modules = Compilation_context.modules cctx in Memo.parallel_iter - (Modules.fold_no_vlib_with_aliases + (Modules.With_vlib.fold_no_vlib_with_aliases modules ~init:[] ~normal:(fun x acc -> `Normal x :: acc) @@ -515,7 +515,7 @@ let build_all cctx = build_module cctx m | _ -> let cctx = - if Modules.is_stdlib_alias modules m + if Modules.With_vlib.is_stdlib_alias modules m then (* XXX it would probably be simpler if the flags were just for this module in the definition of the stanza *) diff --git a/src/dune_rules/modules.ml b/src/dune_rules/modules.ml index 5657475af95..6d4d417514d 100644 --- a/src/dune_rules/modules.ml +++ b/src/dune_rules/modules.ml @@ -762,24 +762,18 @@ module Sourced_module = struct ;; end -type t = - { obj_map : Sourced_module.t Module_name.Unique.Map.t Lazy.t - ; modules : modules - } - -and modules = +type modules = | Singleton of Module.t | Unwrapped of Unwrapped.t | Wrapped of Wrapped.t - | Impl of impl | Stdlib of Stdlib.t -and impl = - { impl : t - ; vlib : t +type t = + { obj_map : Sourced_module.t Module_name.Unique.Map.t Lazy.t + ; modules : modules } -let rec obj_map : 'a. modules -> Sourced_module.t Module_name.Unique.Map.t = +let obj_map : 'a. modules -> Sourced_module.t Module_name.Unique.Map.t = let module Map = Module_name.Unique.Map in let normal m = Sourced_module.Normal m in let f m acc = Map.add_exn acc (Module.obj_name m) (normal m) in @@ -789,16 +783,6 @@ let rec obj_map : 'a. modules -> Sourced_module.t Module_name.Unique.Map.t = | Unwrapped m -> Unwrapped.fold m ~init:Map.empty ~f | Wrapped w -> Wrapped.fold w ~init:Map.empty ~f | Stdlib w -> Stdlib.fold w ~init:Map.empty ~f - | Impl { vlib; impl } -> - Map.merge (obj_map vlib.modules) (obj_map impl.modules) ~f:(fun _ vlib impl -> - match vlib, impl with - | None, None -> assert false - | Some (Normal m), None -> Some (Sourced_module.Imported_from_vlib m) - | None, Some (Normal m) -> Some (Normal m) - | Some (Normal intf), Some (Normal impl) -> - Some (Sourced_module.Impl_of_virtual_module { intf; impl }) - | Some (Imported_from_vlib _ | Impl_of_virtual_module _), _ - | _, Some (Imported_from_vlib _ | Impl_of_virtual_module _) -> assert false) ;; let with_obj_map modules = @@ -808,18 +792,6 @@ let with_obj_map modules = let obj_map t = Lazy.force t.obj_map -let rec encode t ~src_dir = - let open Dune_sexp in - match t.modules with - | Singleton m -> List (atom "singleton" :: Module.encode m ~src_dir) - | Unwrapped m -> List (atom "unwrapped" :: Unwrapped.encode m ~src_dir) - | Wrapped m -> List (atom "wrapped" :: Wrapped.encode m ~src_dir) - | Stdlib m -> List (atom "stdlib" :: Stdlib.encode m ~src_dir) - | Impl { impl; _ } -> encode impl ~src_dir -;; - -let singleton m = with_obj_map (Singleton m) - let decode ~src_dir = let open Dune_lang.Decoder in sum @@ -839,36 +811,13 @@ let decode ~src_dir = >>| with_obj_map ;; -let rec to_dyn t = +let to_dyn t = let open Dyn in match t.modules with | Singleton m -> variant "Singleton" [ Module.to_dyn m ] | Unwrapped m -> variant "Unwrapped" [ Unwrapped.to_dyn m ] | Wrapped w -> variant "Wrapped" [ Wrapped.to_dyn w ] | Stdlib s -> variant "Stdlib" [ Stdlib.to_dyn s ] - | Impl impl -> variant "Impl" [ dyn_of_impl impl ] - -and dyn_of_impl { impl; vlib } = - let open Dyn in - record [ "impl", to_dyn impl; "vlib", to_dyn vlib ] -;; - -let rec lib_interface t = - match t.modules with - | Singleton m -> Some m - | Unwrapped _ -> None - | Wrapped w -> Some (Wrapped.lib_interface w) - | Stdlib w -> Stdlib.lib_interface w - | Impl { impl = _; vlib } -> lib_interface vlib -;; - -let rec main_module_name t = - match t.modules with - | Singleton m -> Some (Module.name m) - | Unwrapped _ -> None - | Wrapped w -> Some w.group.name - | Stdlib w -> Some w.main_module_name - | Impl { vlib; impl = _ } -> main_module_name vlib ;; let lib ~obj_dir ~main_module_name ~wrapped ~stdlib ~lib_name ~implements ~modules = @@ -900,67 +849,6 @@ let lib ~obj_dir ~main_module_name ~wrapped ~stdlib ~lib_name ~implements ~modul with_obj_map modules ;; -let impl impl ~vlib = - let modules = - match impl.modules, vlib.modules with - | _, Impl _ | Impl _, _ | Stdlib _, _ | _, Stdlib _ -> - Code_error.raise - "Modules.impl: invalid arguments" - [ "impl", to_dyn impl; "vlib", to_dyn vlib ] - | _, _ -> Impl { impl; vlib } - in - with_obj_map modules -;; - -let rec find t name = - match t.modules with - | Singleton m -> Option.some_if (Module.name m = name) m - | Unwrapped m -> Unwrapped.find m name - | Stdlib w -> Stdlib.find w name - | Wrapped w -> Wrapped.find w name - | Impl { impl; vlib } -> - (match find impl name with - | Some _ as m -> m - | None -> find vlib name) -;; - -exception Parent_cycle - -let find_dep = - let from_impl_or_lib = List.map ~f:(fun m -> `Impl_or_lib, m) in - let find_dep_result = - List.filter_map ~f:(fun (from, m) -> - match from with - | `Impl_or_lib -> Some m - | `Vlib -> Option.some_if (Module.visibility m = Public) m) - in - let raise_parent_cycle = function - | Ok s -> from_impl_or_lib s - | Error `Parent_cycle -> raise_notrace Parent_cycle - in - let rec find_dep t ~of_ name : Module.t list = - if Module.name of_ = name - then [] - else ( - let result = - match t.modules with - | Singleton _ -> find t name |> Option.to_list |> from_impl_or_lib - | Unwrapped w -> Unwrapped.find_dep w ~of_ name |> raise_parent_cycle - | Wrapped w -> Wrapped.find_dep w ~of_ name |> raise_parent_cycle - | Stdlib s -> Stdlib.find_dep s ~of_ name |> Option.to_list |> from_impl_or_lib - | Impl { vlib; impl } -> - (match find_dep impl ~of_ name with - | [] -> find_dep vlib ~of_ name |> List.map ~f:(fun m -> `Vlib, m) - | xs -> from_impl_or_lib xs) - in - find_dep_result result) - in - fun t ~of_ name -> - match find_dep t ~of_ name with - | s -> Ok s - | exception Parent_cycle -> Error `Parent_cycle -;; - let make_singleton m mangle = let modules = Singleton @@ -971,8 +859,6 @@ let make_singleton m mangle = with_obj_map modules ;; -let singleton_exe m = make_singleton m Exe - let exe_unwrapped modules ~obj_dir = let mangle = Mangle.Unwrapped in let modules = Unwrapped (Unwrapped.of_trie modules ~mangle ~obj_dir) in @@ -992,125 +878,19 @@ let make_wrapped ~obj_dir ~modules kind = with_obj_map modules ;; -let rec impl_only t = - match t.modules with - | Stdlib w -> Stdlib.impl_only w - | Singleton m -> if Module.has ~ml_kind:Impl m then [ m ] else [] - | Unwrapped m -> - Unwrapped.fold m ~init:[] ~f:(fun v acc -> - if Module.has v ~ml_kind:Impl then v :: acc else acc) - | Wrapped w -> Wrapped.impl_only w - | Impl { vlib; impl } -> impl_only impl @ impl_only vlib -;; - -let rec exists t ~f = - match t.modules with - | Stdlib w -> Stdlib.exists w ~f - | Wrapped m -> Wrapped.exists m ~f - | Singleton m -> f m - | Unwrapped m -> Unwrapped.exists m ~f - | Impl { vlib; impl } -> exists vlib ~f || exists impl ~f -;; - -let has_impl = - let has = Module.has ~ml_kind:Impl in - exists ~f:has -;; - -let rec fold_no_vlib t ~init ~f = +let fold t ~init ~f = match t.modules with | Stdlib w -> Stdlib.fold w ~init ~f | Singleton m -> f m init | Unwrapped m -> Unwrapped.fold m ~f ~init | Wrapped w -> Wrapped.fold w ~init ~f - | Impl { vlib = _; impl } -> fold_no_vlib impl ~f ~init -;; - -let fold_no_vlib_with_aliases = - let rec group_of_alias t m = - match t.modules with - | Wrapped w -> Some (Wrapped.group_of_alias w m) - | Unwrapped w -> Some (Unwrapped.group_of_alias w m) - | Impl { vlib; impl } -> - let vlib = group_of_alias vlib m in - let impl = group_of_alias impl m in - (match vlib, impl with - | None, None -> assert false - | Some _, None -> vlib - | None, Some _ -> impl - | Some vlib, Some impl -> - let modules = - Module_name.Map.merge vlib.modules impl.modules ~f:(fun _ vlib impl -> - match vlib, impl with - | None, None -> assert false - | _, Some _ -> impl - | Some vlib, _ -> - let vlib = - match (vlib : Group.node) with - | Module m -> m - | Group g -> Group.lib_interface g - in - Option.some_if (Module.visibility vlib = Public) vlib - |> Option.map ~f:(fun m -> Group.Module m)) - in - Some { impl with Group.modules }) - | _ -> None - in - fun t ~init ~normal ~alias -> - fold_no_vlib t ~init ~f:(fun m acc -> - match Module.kind m with - | Alias _ -> - (match group_of_alias t m with - | None -> - Code_error.raise - "alias module for group without alias" - [ "t", to_dyn t; "m", Module.to_dyn m ] - | Some group -> alias group acc) - | _ -> normal m acc) -;; - -type split_by_lib = - { vlib : Module.t list - ; impl : Module.t list - } - -let split_by_lib t = - let f m acc = m :: acc in - let init = [] in - match t.modules with - | Impl { vlib; impl } -> - let vlib = fold_no_vlib vlib ~init ~f in - let impl = fold_no_vlib impl ~init ~f in - { vlib; impl } - | _ -> { impl = fold_no_vlib t ~init ~f; vlib = [] } -;; - -let compat_for_exn t m = - match t.modules with - | Singleton _ | Stdlib _ | Unwrapped _ -> assert false - | Impl _ -> Code_error.raise "wrapped compat not supported for vlib" [] - | Wrapped { group; _ } -> - (match Module_name.Map.find group.modules (Module.name m) with - | None -> assert false - | Some (Module m) -> m - | Some (Group g) -> Group.lib_interface g) ;; -let wrapped_compat t = +let wrapped t = match t.modules with - | Stdlib _ | Singleton _ | Impl _ | Unwrapped _ -> Module_name.Map.empty - | Wrapped w -> w.wrapped_compat -;; - -let rec fold_user_available t ~f ~init = - match t.modules with - | Stdlib w -> Stdlib.fold w ~init ~f - | Singleton m -> f m init - | Unwrapped modules -> Unwrapped.fold modules ~init ~f - | Wrapped w -> Wrapped.fold_user_available w ~init ~f - | Impl { impl; vlib = _ } -> - (* XXX shouldn't we folding over [vlib] as well? *) - fold_user_available impl ~f ~init + | Wrapped w -> w.wrapped + | Singleton _ | Unwrapped _ -> Simple false + | Stdlib _ -> Simple true ;; let is_user_written m = @@ -1119,17 +899,15 @@ let is_user_written m = | _ -> true ;; -let rec fold_user_written t ~f ~init = - let f m acc = if is_user_written m then f m acc else acc in +let fold_user_available t ~f ~init = match t.modules with | Stdlib w -> Stdlib.fold w ~init ~f | Singleton m -> f m init | Unwrapped modules -> Unwrapped.fold modules ~init ~f - | Wrapped { group; _ } -> Group.fold group ~init ~f - | Impl { impl; vlib = _ } -> fold_user_written impl ~f ~init + | Wrapped w -> Wrapped.fold_user_available w ~init ~f ;; -let rec map_user_written t ~f = +let map_user_written t ~f = let f m = if is_user_written m then f m else Memo.return m in let open Memo.O in let+ modules = @@ -1146,122 +924,438 @@ let rec map_user_written t ~f = | Wrapped ({ group; wrapped_compat = _; wrapped = _; toplevel_module = _ } as w) -> let+ group = Group.Memo_traversals.parallel_map group ~f in Wrapped { w with group } - | Impl t -> - let+ modules = map_user_written t.impl ~f in - Impl { t with impl = modules } in with_obj_map modules ;; -let version_installed t ~src_root ~install_dir = - let f = Module.version_installed ~src_root ~install_dir in - let rec loop t = - let modules = - match t.modules with - | Singleton m -> Singleton (f m) - | Unwrapped m -> Unwrapped (Unwrapped.map ~f m) - | Stdlib w -> Stdlib (Stdlib.map w ~f) - | Wrapped w -> Wrapped (Wrapped.map w ~f) - | Impl w -> Impl { w with impl = loop w.impl } - in - with_obj_map modules - in - loop t -;; - -let entry_modules t = - List.filter - ~f:(fun m -> Module.visibility m = Public) - (match t.modules with - | Stdlib w -> Stdlib.lib_interface w |> Option.to_list - | Singleton m -> [ m ] - | Unwrapped m -> Unwrapped.entry_modules m - | Wrapped m -> - (* we assume this is never called for implementations *) - [ Wrapped.lib_interface m ] - | Impl i -> - Code_error.raise - "entry_modules: not defined for implementations" - [ "impl", dyn_of_impl i ]) +let fold_user_written t ~f ~init = + let f m acc = if is_user_written m then f m acc else acc in + match t.modules with + | Stdlib w -> Stdlib.fold w ~init ~f + | Singleton m -> f m init + | Unwrapped modules -> Unwrapped.fold modules ~init ~f + | Wrapped { group; _ } -> Group.fold group ~init ~f ;; let virtual_module_names = - fold_no_vlib ~init:Module_name.Path.Set.empty ~f:(fun m acc -> + fold ~init:Module_name.Path.Set.empty ~f:(fun m acc -> match Module.kind m with | Virtual -> Module_name.Path.Set.add acc [ Module.name m ] | _ -> acc) ;; -let rec wrapped t = - match t.modules with - | Wrapped w -> w.wrapped - | Singleton _ | Unwrapped _ -> Simple false - | Stdlib _ -> Simple true - | Impl { vlib = _; impl } -> wrapped impl +let source_dirs = + fold_user_written ~init:Path.Set.empty ~f:(fun m acc -> + Module.sources m + |> List.fold_left ~init:acc ~f:(fun acc f -> Path.Set.add acc (Path.parent_exn f))) ;; -let rec alias_for t m = - match Module.kind m with - | Root -> [] - | _ -> - (match t.modules with - | Singleton _ -> [] - | Unwrapped w -> Unwrapped.alias_for w m - | Wrapped w -> Wrapped.alias_for w m - | Stdlib w -> Stdlib.alias_for w m |> Option.to_list - | Impl { impl; vlib = _ } -> alias_for impl m) -;; +module With_vlib = struct + type impl = + { obj_map : Sourced_module.t Module_name.Unique.Map.t Lazy.t + ; impl : t + ; vlib : t + } -let rec group_interfaces t m = - match t.modules with - | Wrapped w -> Wrapped.group_interfaces w m - | Impl { impl; vlib } -> group_interfaces impl m @ group_interfaces vlib m - | Singleton w -> [ w ] - | _ -> [] -;; + type nonrec t = + | Modules of t + | Impl of impl + + let modules m = Modules m + let with_modules_obj_map = with_obj_map + + let with_obj_map = + let modules_obj_map = obj_map in + let obj_map : impl -> Sourced_module.t Module_name.Unique.Map.t = + let module Map = Module_name.Unique.Map in + fun t -> + let { obj_map = _; vlib; impl } = t in + Map.merge (modules_obj_map vlib) (modules_obj_map impl) ~f:(fun _ vlib impl -> + match vlib, impl with + | None, None -> assert false + | Some (Normal m), None -> Some (Sourced_module.Imported_from_vlib m) + | None, Some (Normal m) -> Some (Normal m) + | Some (Normal intf), Some (Normal impl) -> + Some (Sourced_module.Impl_of_virtual_module { intf; impl }) + | Some (Imported_from_vlib _ | Impl_of_virtual_module _), _ + | _, Some (Imported_from_vlib _ | Impl_of_virtual_module _) -> assert false) + in + function + | Modules t -> Modules (with_modules_obj_map t.modules) + | Impl t -> + let obj_map = lazy (obj_map t) in + Impl { t with obj_map } + ;; -let local_open t m = - alias_for t m - |> List.map ~f:(fun m -> Module.obj_name m |> Module_name.Unique.to_name ~loc:Loc.none) -;; + let obj_map = function + | Modules t -> obj_map t + | Impl { obj_map; _ } -> Lazy.force obj_map + ;; -let is_stdlib_alias t m = - match t.modules with - | Stdlib w -> w.main_module_name = Module.name m - | _ -> false -;; + let encode = + let encode t ~src_dir = + let open Dune_sexp in + match t.modules with + | Singleton m -> List (atom "singleton" :: Module.encode m ~src_dir) + | Unwrapped m -> List (atom "unwrapped" :: Unwrapped.encode m ~src_dir) + | Wrapped m -> List (atom "wrapped" :: Wrapped.encode m ~src_dir) + | Stdlib m -> List (atom "stdlib" :: Stdlib.encode m ~src_dir) + in + fun t ~src_dir -> + match t with + | Modules m -> encode m ~src_dir + | Impl { impl; _ } -> encode impl ~src_dir + ;; -let exit_module t = - match t.modules with - | Stdlib w -> Stdlib.exit_module w - | _ -> None -;; + let singleton m = Modules (with_modules_obj_map (Singleton m)) -let as_singleton t = - match t.modules with - | Singleton m -> Some m - | _ -> None -;; + let dyn_of_impl { impl; vlib; _ } = + let open Dyn in + record [ "impl", to_dyn impl; "vlib", to_dyn vlib ] + ;; -let source_dirs = - fold_user_written ~init:Path.Set.empty ~f:(fun m acc -> - Module.sources m - |> List.fold_left ~init:acc ~f:(fun acc f -> Path.Set.add acc (Path.parent_exn f))) -;; + let modules_to_dyn = to_dyn -let canonical_path t (group : Group.t) m = - let path = - let path = Module.path m in - match Module_name.Map.find group.modules (Module.name m) with - | None | Some (Group.Module _) -> path - | Some (Group _) -> - (* The path for group interfaces always duplicates - the last component. - - For example: foo/foo.ml would has the path [ "Foo"; "Foo" ] *) - List.remove_last_exn path - in - match t.modules with - | Impl { impl = { modules = Wrapped w; _ }; _ } | Wrapped w -> w.group.name :: path - | _ -> Module.path m -;; + let to_dyn t = + let open Dyn in + match t with + | Modules t -> variant "Modules" [ modules_to_dyn t ] + | Impl impl -> variant "Impl" [ dyn_of_impl impl ] + ;; + + let lib_interface = + let lib_interface t = + match t.modules with + | Singleton m -> Some m + | Unwrapped _ -> None + | Wrapped w -> Some (Wrapped.lib_interface w) + | Stdlib w -> Stdlib.lib_interface w + in + function + | Modules t -> lib_interface t + | Impl { impl = _; vlib; _ } -> lib_interface vlib + ;; + + let main_module_name = + let main_module_name t = + match t.modules with + | Singleton m -> Some (Module.name m) + | Unwrapped _ -> None + | Wrapped w -> Some w.group.name + | Stdlib w -> Some w.main_module_name + in + function + | Modules t -> main_module_name t + | Impl { vlib; impl = _; _ } -> main_module_name vlib + ;; + + let impl = + let empty = lazy Module_name.Unique.Map.empty in + fun impl ~vlib -> + let modules = + match impl.modules, vlib.modules with + | Stdlib _, _ | _, Stdlib _ -> + Code_error.raise + "Modules.impl: invalid arguments" + [ "impl", modules_to_dyn impl; "vlib", modules_to_dyn vlib ] + | _, _ -> Impl { obj_map = empty; impl; vlib } + in + with_obj_map modules + ;; + + let modules_find t name = + match t.modules with + | Singleton m -> Option.some_if (Module.name m = name) m + | Unwrapped m -> Unwrapped.find m name + | Stdlib w -> Stdlib.find w name + | Wrapped w -> Wrapped.find w name + ;; + + let find t name = + match t with + | Modules t -> modules_find t name + | Impl { impl; vlib; _ } -> + (match modules_find impl name with + | Some _ as m -> m + | None -> modules_find vlib name) + ;; + + exception Parent_cycle + + let find_dep = + let from_impl_or_lib = List.map ~f:(fun m -> `Impl_or_lib, m) in + let find_dep_result = + List.filter_map ~f:(fun (from, m) -> + match from with + | `Impl_or_lib -> Some m + | `Vlib -> Option.some_if (Module.visibility m = Public) m) + in + let raise_parent_cycle = function + | Ok s -> from_impl_or_lib s + | Error `Parent_cycle -> raise_notrace Parent_cycle + in + let find_dep t ~of_ name : Module.t list = + if Module.name of_ = name + then [] + else ( + let result = + match t.modules with + | Singleton _ -> modules_find t name |> Option.to_list |> from_impl_or_lib + | Unwrapped w -> Unwrapped.find_dep w ~of_ name |> raise_parent_cycle + | Wrapped w -> Wrapped.find_dep w ~of_ name |> raise_parent_cycle + | Stdlib s -> Stdlib.find_dep s ~of_ name |> Option.to_list |> from_impl_or_lib + in + find_dep_result result) + in + fun t ~of_ name -> + try + Ok + (match t with + | Modules t -> find_dep t ~of_ name + | Impl { vlib; impl; _ } -> + (match find_dep impl ~of_ name with + | [] -> find_dep vlib ~of_ name |> List.map ~f:(fun m -> `Vlib, m) + | xs -> from_impl_or_lib xs) + |> find_dep_result) + with + | Parent_cycle -> Error `Parent_cycle + ;; + + let singleton_exe m = Modules (make_singleton m Exe) + + let impl_only = + let impl_only t = + match t.modules with + | Stdlib w -> Stdlib.impl_only w + | Singleton m -> if Module.has ~ml_kind:Impl m then [ m ] else [] + | Unwrapped m -> + Unwrapped.fold m ~init:[] ~f:(fun v acc -> + if Module.has v ~ml_kind:Impl then v :: acc else acc) + | Wrapped w -> Wrapped.impl_only w + in + fun t -> + match t with + | Modules t -> impl_only t + | Impl { vlib; impl; _ } -> impl_only impl @ impl_only vlib + ;; + + let exists = + let exists t ~f = + match t.modules with + | Stdlib w -> Stdlib.exists w ~f + | Wrapped m -> Wrapped.exists m ~f + | Singleton m -> f m + | Unwrapped m -> Unwrapped.exists m ~f + in + fun t ~f -> + match t with + | Modules t -> exists t ~f + | Impl { vlib; impl; _ } -> exists vlib ~f || exists impl ~f + ;; + + let has_impl = + let has = Module.has ~ml_kind:Impl in + exists ~f:has + ;; + + let drop_vlib = function + | Modules t -> t + | Impl { vlib = _; impl; _ } -> impl + ;; + + let fold_no_vlib_with_aliases = + let group_of_alias t m = + match t.modules with + | Wrapped w -> Some (Wrapped.group_of_alias w m) + | Unwrapped w -> Some (Unwrapped.group_of_alias w m) + | _ -> None + in + let group_of_alias t m = + match t with + | Modules t -> group_of_alias t m + | Impl { vlib; impl; _ } -> + let vlib = group_of_alias vlib m in + let impl = group_of_alias impl m in + (match vlib, impl with + | None, None -> assert false + | Some _, None -> vlib + | None, Some _ -> impl + | Some vlib, Some impl -> + let modules = + Module_name.Map.merge vlib.modules impl.modules ~f:(fun _ vlib impl -> + match vlib, impl with + | None, None -> assert false + | _, Some _ -> impl + | Some vlib, _ -> + let vlib = + match (vlib : Group.node) with + | Module m -> m + | Group g -> Group.lib_interface g + in + Option.some_if (Module.visibility vlib = Public) vlib + |> Option.map ~f:(fun m -> Group.Module m)) + in + Some { impl with Group.modules }) + in + fun t ~init ~normal ~alias -> + t + |> drop_vlib + |> fold ~init ~f:(fun m acc -> + match Module.kind m with + | Alias _ -> + (match group_of_alias t m with + | None -> + Code_error.raise + "alias module for group without alias" + [ "t", to_dyn t; "m", Module.to_dyn m ] + | Some group -> alias group acc) + | _ -> normal m acc) + ;; + + type split_by_lib = + { vlib : Module.t list + ; impl : Module.t list + } + + let split_by_lib t = + let f m acc = m :: acc in + let init = [] in + match t with + | Impl { vlib; impl; _ } -> + let vlib = fold vlib ~init ~f in + let impl = fold impl ~init ~f in + { vlib; impl } + | Modules t -> { impl = fold t ~init ~f; vlib = [] } + ;; + + let compat_for_exn t m = + match t with + | Impl _ -> Code_error.raise "wrapped compat not supported for vlib" [] + | Modules t -> + (match t.modules with + | Singleton _ | Stdlib _ | Unwrapped _ -> assert false + | Wrapped { group; _ } -> + (match Module_name.Map.find group.modules (Module.name m) with + | None -> assert false + | Some (Module m) -> m + | Some (Group g) -> Group.lib_interface g)) + ;; + + let wrapped_compat t = + match t with + | Impl _ | Modules { modules = Stdlib _ | Singleton _ | Unwrapped _; _ } -> + Module_name.Map.empty + | Modules { modules = Wrapped w; _ } -> w.wrapped_compat + ;; + + let version_installed t ~src_root ~install_dir = + let f = Module.version_installed ~src_root ~install_dir in + let map t = + let modules = + match t.modules with + | Singleton m -> Singleton (f m) + | Unwrapped m -> Unwrapped (Unwrapped.map ~f m) + | Stdlib w -> Stdlib (Stdlib.map w ~f) + | Wrapped w -> Wrapped (Wrapped.map w ~f) + in + with_modules_obj_map modules + in + match t with + | Modules t -> Modules (map t) + | Impl w -> Impl { w with impl = map w.impl } + ;; + + let entry_modules = function + | Impl i -> + Code_error.raise + "entry_modules: not defined for implementations" + [ "impl", dyn_of_impl i ] + | Modules t -> + List.filter + ~f:(fun m -> Module.visibility m = Public) + (match t.modules with + | Stdlib w -> Stdlib.lib_interface w |> Option.to_list + | Singleton m -> [ m ] + | Unwrapped m -> Unwrapped.entry_modules m + | Wrapped m -> + (* we assume this is never called for implementations *) + [ Wrapped.lib_interface m ]) + ;; + + let wrapped = function + | Modules t -> wrapped t + | Impl { vlib = _; impl; _ } -> wrapped impl + ;; + + let alias_for = + let alias_for t m = + match t.modules with + | Singleton _ -> [] + | Unwrapped w -> Unwrapped.alias_for w m + | Wrapped w -> Wrapped.alias_for w m + | Stdlib w -> Stdlib.alias_for w m |> Option.to_list + in + fun t m -> + match Module.kind m with + | Root -> [] + | _ -> + (match t with + | Modules t -> alias_for t m + | Impl { impl; vlib = _; _ } -> alias_for impl m) + ;; + + let group_interfaces = + let group_interfaces t m = + match t.modules with + | Wrapped w -> Wrapped.group_interfaces w m + | Singleton w -> [ w ] + | _ -> [] + in + fun t m -> + match t with + | Modules t -> group_interfaces t m + | Impl { impl; vlib; _ } -> group_interfaces impl m @ group_interfaces vlib m + ;; + + let local_open t m = + alias_for t m + |> List.map ~f:(fun m -> + Module.obj_name m |> Module_name.Unique.to_name ~loc:Loc.none) + ;; + + let is_stdlib_alias t m = + match t with + | Modules { modules = Stdlib w; _ } -> w.main_module_name = Module.name m + | _ -> false + ;; + + let exit_module t = + match t with + | Modules { modules = Stdlib w; _ } -> Stdlib.exit_module w + | _ -> None + ;; + + let as_singleton t = + match t with + | Modules { modules = Singleton m; _ } -> Some m + | _ -> None + ;; + + let canonical_path t (group : Group.t) m = + let path = + let path = Module.path m in + match Module_name.Map.find group.modules (Module.name m) with + | None | Some (Group.Module _) -> path + | Some (Group _) -> + (* The path for group interfaces always duplicates + the last component. + + For example: foo/foo.ml would has the path [ "Foo"; "Foo" ] *) + List.remove_last_exn path + in + match t with + | Impl { impl = { modules = Wrapped w; _ }; _ } | Modules { modules = Wrapped w; _ } + -> w.group.name :: path + | _ -> Module.path m + ;; +end diff --git a/src/dune_rules/modules.mli b/src/dune_rules/modules.mli index be2ef790dcb..7bd15ef27f8 100644 --- a/src/dune_rules/modules.mli +++ b/src/dune_rules/modules.mli @@ -16,27 +16,8 @@ val lib -> modules:Module.t Module_trie.t -> t -val encode : t -> src_dir:Path.t -> Dune_lang.t val decode : src_dir:Path.t -> t Dune_lang.Decoder.t -val impl : t -> vlib:t -> t - -val find_dep - : t - -> of_:Module.t - -> Module_name.t - -> (Module.t list, [ `Parent_cycle ]) result - -val find : t -> Module_name.t -> Module.t option -val compat_for_exn : t -> Module.t -> Module.t -val impl_only : t -> Module.t list - -(** A set of modules from a single module. Not suitable for single module exe as - this produce an unwrapped set of modules. Use [singleton_exe] instead for - executables. *) -val singleton : Module.t -> t - -val singleton_exe : Module.t -> t -val fold_no_vlib : t -> init:'acc -> f:(Module.t -> 'acc -> 'acc) -> 'acc +val fold : t -> init:'acc -> f:(Module.t -> 'acc -> 'acc) -> 'acc module Group : sig type t @@ -46,15 +27,6 @@ module Group : sig val for_alias : t -> (Module_name.t * Module.t) list end -val canonical_path : t -> Group.t -> Module.t -> Module_name.Path.t - -val fold_no_vlib_with_aliases - : t - -> init:'acc - -> normal:(Module.t -> 'acc -> 'acc) - -> alias:(Group.t -> 'acc -> 'acc) - -> 'acc - val exe_unwrapped : Module.t Module_trie.t -> obj_dir:Path.Build.t -> t val make_wrapped @@ -63,17 +35,10 @@ val make_wrapped -> [ `Exe | `Melange ] -> t -(** For wrapped libraries, this is the user written entry module for the - library. For single module libraries, it's the sole module in the library *) -val lib_interface : t -> Module.t option - val fold_user_written : t -> f:(Module.t -> 'acc -> 'acc) -> init:'acc -> 'acc val map_user_written : t -> f:(Module.t -> Module.t Memo.t) -> t Memo.t val fold_user_available : t -> f:(Module.t -> 'acc -> 'acc) -> init:'acc -> 'acc -(** Returns all the compatibility modules. *) -val wrapped_compat : t -> Module.Name_map.t - module Sourced_module : sig type t = | Normal of Module.t @@ -85,34 +50,81 @@ end val obj_map : t -> Sourced_module.t Module_name.Unique.Map.t -(** List of entry modules visible to users of the library. For wrapped - libraries, this is always one module. For unwrapped libraries, this could be - more than one. *) -val entry_modules : t -> Module.t list - -(** Returns the main module name if it exists. It exist for libraries with - [(wrapped true)] or one module libraries. *) -val main_module_name : t -> Module_name.t option - (** Returns only the virtual module names in the library *) val virtual_module_names : t -> Module_name.Path.Set.t val wrapped : t -> Wrapped.t -val version_installed : t -> src_root:Path.t -> install_dir:Path.t -> t -val alias_for : t -> Module.t -> Module.t list -val group_interfaces : t -> Module.t -> Module.t list -val local_open : t -> Module.t -> Module_name.t list -val is_stdlib_alias : t -> Module.t -> bool -val exit_module : t -> Module.t option -val as_singleton : t -> Module.t option val source_dirs : t -> Path.Set.t -type split_by_lib = - { vlib : Module.t list - ; impl : Module.t list - } - -val split_by_lib : t -> split_by_lib +module With_vlib : sig + type modules := t + type t -(** [has_impl t] is true if there's at least one implementation in [t]*) -val has_impl : t -> bool + val drop_vlib : t -> modules + val to_dyn : t -> Dyn.t + val encode : t -> src_dir:Path.t -> Dune_lang.t + val impl : modules -> vlib:modules -> t + + val find_dep + : t + -> of_:Module.t + -> Module_name.t + -> (Module.t list, [ `Parent_cycle ]) result + + val find : t -> Module_name.t -> Module.t option + val compat_for_exn : t -> Module.t -> Module.t + val impl_only : t -> Module.t list + + (** A set of modules from a single module. Not suitable for single module exe as + this produce an unwrapped set of modules. Use [singleton_exe] instead for + executables. *) + val singleton : Module.t -> t + + val canonical_path : t -> Group.t -> Module.t -> Module_name.Path.t + + val fold_no_vlib_with_aliases + : t + -> init:'acc + -> normal:(Module.t -> 'acc -> 'acc) + -> alias:(Group.t -> 'acc -> 'acc) + -> 'acc + + (** For wrapped libraries, this is the user written entry module for the + library. For single module libraries, it's the sole module in the library *) + val lib_interface : t -> Module.t option + + (** Returns all the compatibility modules. *) + val wrapped_compat : t -> Module.Name_map.t + + (** List of entry modules visible to users of the library. For wrapped + libraries, this is always one module. For unwrapped libraries, this could be + more than one. *) + val entry_modules : t -> Module.t list + + (** Returns the main module name if it exists. It exist for libraries with + [(wrapped true)] or one module libraries. *) + val main_module_name : t -> Module_name.t option + + val version_installed : t -> src_root:Path.t -> install_dir:Path.t -> t + val alias_for : t -> Module.t -> Module.t list + val group_interfaces : t -> Module.t -> Module.t list + val local_open : t -> Module.t -> Module_name.t list + val is_stdlib_alias : t -> Module.t -> bool + val exit_module : t -> Module.t option + val as_singleton : t -> Module.t option + + type split_by_lib = + { vlib : Module.t list + ; impl : Module.t list + } + + val split_by_lib : t -> split_by_lib + + (** [has_impl t] is true if there's at least one implementation in [t]*) + val has_impl : t -> bool + + val modules : modules -> t + val singleton_exe : Module.t -> t + val obj_map : t -> Sourced_module.t Module_name.Unique.Map.t + val wrapped : t -> Wrapped.t +end diff --git a/src/dune_rules/ocamldep.ml b/src/dune_rules/ocamldep.ml index 2a87b750896..3ee8b96f36c 100644 --- a/src/dune_rules/ocamldep.ml +++ b/src/dune_rules/ocamldep.ml @@ -6,7 +6,7 @@ module Modules_data = struct ; obj_dir : Path.Build.t Obj_dir.t ; sctx : Super_context.t ; vimpl : Vimpl.t option - ; modules : Modules.t + ; modules : Modules.With_vlib.t ; stdlib : Ocaml_stdlib.t option ; sandbox : Sandbox_config.t } @@ -17,7 +17,7 @@ open Modules_data let parse_module_names ~dir ~(unit : Module.t) ~modules words = List.concat_map words ~f:(fun m -> let m = Module_name.of_string m in - match Modules.find_dep modules ~of_:unit m with + match Modules.With_vlib.find_dep modules ~of_:unit m with | Ok s -> s | Error `Parent_cycle -> User_error.raise @@ -37,7 +37,7 @@ let parse_module_names ~dir ~(unit : Module.t) ~modules words = ;; let parse_compilation_units ~modules = - let obj_map = Modules.obj_map modules in + let obj_map = Modules.With_vlib.obj_map modules in List.filter_map ~f:(fun m -> let obj_name = Module_name.Unique.of_string m in Module_name.Unique.Map.find obj_map obj_name diff --git a/src/dune_rules/ocamldep.mli b/src/dune_rules/ocamldep.mli index db18688e671..3d403e66cbd 100644 --- a/src/dune_rules/ocamldep.mli +++ b/src/dune_rules/ocamldep.mli @@ -13,7 +13,7 @@ module Modules_data : sig ; obj_dir : Path.Build.t Obj_dir.t ; sctx : Super_context.t ; vimpl : Vimpl.t option - ; modules : Modules.t + ; modules : Modules.With_vlib.t ; stdlib : Ocaml_stdlib.t option ; sandbox : Sandbox_config.t } @@ -27,7 +27,7 @@ val deps_of val read_deps_of : obj_dir:Path.Build.t Obj_dir.t - -> modules:Modules.t + -> modules:Modules.With_vlib.t -> ml_kind:Ml_kind.t -> Module.t -> Module.t list Action_builder.t @@ -38,7 +38,7 @@ val read_deps_of [ml_kind], then an empty list of dependencies is returned. *) val read_immediate_deps_of : obj_dir:Path.Build.t Obj_dir.t - -> modules:Modules.t + -> modules:Modules.With_vlib.t -> ml_kind:Ml_kind.t -> Module.t -> Module.t list Action_builder.t diff --git a/src/dune_rules/odoc.ml b/src/dune_rules/odoc.ml index ea114085bca..9a8304c8d0b 100644 --- a/src/dune_rules/odoc.ml +++ b/src/dune_rules/odoc.ml @@ -413,7 +413,9 @@ let setup_library_odoc_rules cctx (local_lib : Lib.Local.t) = in Dep.deps ctx package requires, odoc_include_flags in - Modules.fold_no_vlib modules ~init:[] ~f:(fun m acc -> + modules + |> Modules.With_vlib.drop_vlib + |> Modules.fold ~init:[] ~f:(fun m acc -> let compiled = let modes = Lib_info.modes info in let mode = Lib_mode.Map.Set.for_merlin modes in @@ -590,7 +592,9 @@ let libs_of_pkg ctx ~pkg = ;; let entry_modules_by_lib sctx lib = - Dir_contents.modules_of_local_lib sctx lib >>| Modules.entry_modules + Dir_contents.modules_of_local_lib sctx lib + >>| Modules.With_vlib.modules + >>| Modules.With_vlib.entry_modules ;; let entry_modules sctx ~pkg = diff --git a/src/dune_rules/odoc_new.ml b/src/dune_rules/odoc_new.ml index 9418a283914..7875785dbb9 100644 --- a/src/dune_rules/odoc_new.ml +++ b/src/dune_rules/odoc_new.ml @@ -1211,8 +1211,10 @@ let lib_artifacts ctx all index lib modules = | Melange -> Melange Cmi in let obj_dir = Lib_info.obj_dir info in - let entry_modules = Modules.entry_modules modules in - Modules.fold_no_vlib modules ~init:[] ~f:(fun m acc -> + let entry_modules = Modules.With_vlib.entry_modules modules in + modules + |> Modules.With_vlib.drop_vlib + |> Modules.fold ~init:[] ~f:(fun m acc -> let visible = let visible = List.mem entry_modules m ~equal:(fun m1 m2 -> diff --git a/src/dune_rules/pkg_rules.ml b/src/dune_rules/pkg_rules.ml index f4e3f1eaa4d..fdc6b3370bb 100644 --- a/src/dune_rules/pkg_rules.ml +++ b/src/dune_rules/pkg_rules.ml @@ -339,12 +339,10 @@ module Pkg = struct (* Given a list of packages, construct an env containing variables set by each package. Variables containing delimited lists of paths (e.g. PATH) which appear in multiple package's envs are - concatenated in the order of their associated packages in the - input list. Environment updates via the `exported_env` field + concatenated in the reverse order of their associated packages in + the input list. Environment updates via the `exported_env` field (equivalent to opam's `setenv` field) are applied for each - package in reverse order to the argument list so that packages - appearing earlier can overwrite the values of variables set by - packages appearing later. *) + package in the same order as the argument list. *) let build_env_of_deps ts = List.fold_left ts ~init:Env.Map.empty ~f:(fun env t -> let env = @@ -1180,10 +1178,7 @@ end = struct let+ lock_dir = Lock_dir.get_path ctx >>| Option.value_exn in Path.Build.append_source (Context_name.build_dir ctx) - (Path.Source.relative - lock_dir - (* TODO this should come from [Dune_pkg] *) - (sprintf "%s.files" (Package.Name.to_string info.name))) + (Dune_pkg.Lock_dir.Pkg.files_dir info.name ~lock_dir) in let id = Pkg.Id.gen () in let paths = Paths.make name ctx in diff --git a/src/dune_rules/ppx_driver.ml b/src/dune_rules/ppx_driver.ml index 960ba17941f..0cf722fa1e8 100644 --- a/src/dune_rules/ppx_driver.ml +++ b/src/dune_rules/ppx_driver.ml @@ -316,7 +316,7 @@ let build_ppx_driver sctx ~scope ~target ~pps ~pp_names = let requires_link = Memo.lazy_ (fun () -> Memo.return requires_compile) in let flags = Ocaml_flags.of_list [ "-g"; "-w"; "-24" ] in let opaque = Compilation_context.Explicit false in - let modules = Modules.singleton_exe module_ in + let modules = Modules.With_vlib.singleton_exe module_ in Compilation_context.create ~super_context:sctx ~scope diff --git a/src/dune_rules/top_module.ml b/src/dune_rules/top_module.ml index cbb05a5e293..ff7a1012c47 100644 --- a/src/dune_rules/top_module.ml +++ b/src/dune_rules/top_module.ml @@ -56,7 +56,7 @@ let find_module sctx src = in let module_ = let modules = Compilation_context.modules cctx in - match Modules.find modules module_name with + match Modules.With_vlib.find modules module_name with | Some m -> m | None -> User_error.raise diff --git a/src/dune_rules/toplevel.ml b/src/dune_rules/toplevel.ml index b7b22fe9201..a657f7bf3b4 100644 --- a/src/dune_rules/toplevel.ml +++ b/src/dune_rules/toplevel.ml @@ -25,7 +25,7 @@ module Source = struct let modules t pp = let open Memo.O in - main_module t |> Pp_spec.pp_module pp >>| Modules.singleton_exe + main_module t |> Pp_spec.pp_module pp >>| Modules.With_vlib.singleton_exe ;; let make ~dir ~loc ~main ~name = { dir; main; name; loc } diff --git a/src/dune_rules/toplevel.mli b/src/dune_rules/toplevel.mli index 5a483509f9b..73d780af67f 100644 --- a/src/dune_rules/toplevel.mli +++ b/src/dune_rules/toplevel.mli @@ -5,7 +5,7 @@ module Source : sig val make : dir:Path.Build.t -> loc:Loc.t -> main:string -> name:string -> t val loc : t -> Loc.t - val modules : t -> Pp_spec.t -> Modules.t Memo.t + val modules : t -> Pp_spec.t -> Modules.With_vlib.t Memo.t val obj_dir : t -> Path.Build.t Obj_dir.t end diff --git a/src/dune_rules/vimpl.ml b/src/dune_rules/vimpl.ml index 7e4f9b76de5..85d8360419f 100644 --- a/src/dune_rules/vimpl.ml +++ b/src/dune_rules/vimpl.ml @@ -15,8 +15,8 @@ let impl_cm_kind t = t.impl_cm_kind let impl_modules t m = match t with - | None -> m - | Some t -> Modules.impl ~vlib:t.vlib_modules m + | None -> Modules.With_vlib.modules m + | Some t -> Modules.With_vlib.impl ~vlib:t.vlib_modules m ;; let make ~vlib ~impl ~vlib_modules ~vlib_foreign_objects = diff --git a/src/dune_rules/vimpl.mli b/src/dune_rules/vimpl.mli index f4e7289649b..c756b4cd9e2 100644 --- a/src/dune_rules/vimpl.mli +++ b/src/dune_rules/vimpl.mli @@ -18,7 +18,7 @@ val impl : t -> Library.t setting up the copying rules *) val vlib_modules : t -> Modules.t -val impl_modules : t option -> Modules.t -> Modules.t +val impl_modules : t option -> Modules.t -> Modules.With_vlib.t val vlib : t -> Lib.t (** Return the combined list of .o files for stubs consisting of .o files from diff --git a/src/dune_rules/virtual_rules.ml b/src/dune_rules/virtual_rules.ml index 986ba0342be..2d577c21d73 100644 --- a/src/dune_rules/virtual_rules.ml +++ b/src/dune_rules/virtual_rules.ml @@ -56,8 +56,7 @@ let setup_copy_rules_for_impl ~sctx ~dir vimpl = copy_to_obj_dir ~src:(object_file vlib_obj_dir) ~dst:(object_file impl_obj_dir))) in let vlib_modules = Vimpl.vlib_modules vimpl in - Modules.fold_no_vlib vlib_modules ~init:(Memo.return ()) ~f:(fun m acc -> - acc >>> copy_objs m) + Modules.fold vlib_modules ~init:(Memo.return ()) ~f:(fun m acc -> acc >>> copy_objs m) ;; let impl sctx ~(lib : Library.t) ~scope = diff --git a/src/dune_rules/workspace.ml b/src/dune_rules/workspace.ml index ce98579da2b..99ba2963cf4 100644 --- a/src/dune_rules/workspace.ml +++ b/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 = diff --git a/src/dune_rules/workspace.mli b/src/dune_rules/workspace.mli index e6093120b18..ff29b1bceb0 100644 --- a/src/dune_rules/workspace.mli +++ b/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 diff --git a/test/blackbox-tests/test-cases/cxx-flags.t/dune b/test/blackbox-tests/test-cases/cxx-flags.t/dune index 6f4cc7ca904..a3c46259b87 100644 --- a/test/blackbox-tests/test-cases/cxx-flags.t/dune +++ b/test/blackbox-tests/test-cases/cxx-flags.t/dune @@ -8,3 +8,26 @@ (libraries quad) (foreign_stubs (language cxx) (names bazexe)) (modules main)) + +(env + (_ + (ocamlopt_flags + :standard + (:include extra_flags.sexp)))) + +(rule + (enabled_if + (or + (<> %{system} macosx) + (<> %{architecture} arm64))) + (action + (write-file extra_flags.sexp "()"))) + +; with XCode 15+, the linker complains about duplicate -lc++ libraries +(rule + (enabled_if + (and + (= %{system} macosx) + (= %{architecture} arm64))) + (action + (write-file extra_flags.sexp "(-ccopt -Wl,-no_warn_duplicate_libraries)"))) diff --git a/test/blackbox-tests/test-cases/describe/describe-contexts.t b/test/blackbox-tests/test-cases/describe/describe-contexts.t new file mode 100644 index 00000000000..bae930a4820 --- /dev/null +++ b/test/blackbox-tests/test-cases/describe/describe-contexts.t @@ -0,0 +1,19 @@ +Showcase behavior of the `dune describe contexts` subcommand + + $ cat >dune-project < (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 diff --git a/test/blackbox-tests/test-cases/dune b/test/blackbox-tests/test-cases/dune index 72db7618383..109b7753c0a 100644 --- a/test/blackbox-tests/test-cases/dune +++ b/test/blackbox-tests/test-cases/dune @@ -129,7 +129,12 @@ (cram (applies_to version-corruption) - (deps %{bin:od} %{bin:git} %{bin:cmp} %{bin:sed} %{bin:chmod})) + (deps %{bin:git} %{bin:chmod}) + (enabled_if + ; code signing moves placeholders in the binary + (or + (<> %{system} macosx) + (<> %{architecture} arm64)))) (cram (applies_to corrupt-persistent) diff --git a/test/blackbox-tests/test-cases/github2206.t/run.t b/test/blackbox-tests/test-cases/github2206.t/run.t index 2d0989b9469..976772d7dc0 100644 --- a/test/blackbox-tests/test-cases/github2206.t/run.t +++ b/test/blackbox-tests/test-cases/github2206.t/run.t @@ -5,3 +5,7 @@ copy_files would break the generation of the preprocessing flags (FLG (-pp $TESTCASE_ROOT/_build/default/pp.exe)) + -- + (FLG + (-pp + $TESTCASE_ROOT/_build/default/pp.exe)) diff --git a/test/blackbox-tests/test-cases/lib-collision/lib-collision-public-name.t b/test/blackbox-tests/test-cases/lib-collision/lib-collision-public-name.t new file mode 100644 index 00000000000..6f6babafd0c --- /dev/null +++ b/test/blackbox-tests/test-cases/lib-collision/lib-collision-public-name.t @@ -0,0 +1,42 @@ +Public libraries using the same library name, in the same context, defined in +the same folder. + + $ cat > dune-project << EOF + > (lang dune 3.13) + > (package (name bar) (allow_empty)) + > (package (name baz) (allow_empty)) + > EOF + + $ cat > dune << EOF + > (library + > (name foo) + > (public_name bar.foo)) + > (library + > (name foo) + > (public_name baz.foo)) + > EOF + +Without any consumers of the libraries + + $ dune build + File "dune", line 5, characters 7-10: + 5 | (name foo) + ^^^ + Error: Library "foo" appears for the second time in this directory + [1] + + $ rm dune + $ mkdir baz bar + $ cat > bar/dune << EOF + > (library + > (name foo) + > (public_name bar.foo)) + > EOF + $ cat > baz/dune << EOF + > (library + > (name foo) + > (public_name baz.foo)) + > EOF + + $ dune build + diff --git a/test/blackbox-tests/test-cases/melange/merlin-compile-flags.t b/test/blackbox-tests/test-cases/melange/merlin-compile-flags.t index d6dc06619c2..3bd56c798ff 100644 --- a/test/blackbox-tests/test-cases/melange/merlin-compile-flags.t +++ b/test/blackbox-tests/test-cases/melange/merlin-compile-flags.t @@ -21,6 +21,9 @@ Show that the merlin config knows about melange.compile_flags +42))) +42))) +42))) + +42))) + +42))) + +42))) $ cat >dune < (melange.emit @@ -35,4 +38,7 @@ Show that the merlin config knows about melange.compile_flags +42))) +42))) +42))) + +42))) + +42))) + +42))) diff --git a/test/blackbox-tests/test-cases/melange/merlin.t b/test/blackbox-tests/test-cases/melange/merlin.t index 7002f53a1a6..8a4d7e6a873 100644 --- a/test/blackbox-tests/test-cases/melange/merlin.t +++ b/test/blackbox-tests/test-cases/melange/merlin.t @@ -25,11 +25,18 @@ $ dune ocaml merlin dump-config "$PWD" | grep -i "$lib" $TESTCASE_ROOT/_build/default/.foo.objs/melange) (FLG (-open Foo__)) + $TESTCASE_ROOT/_build/default/.foo.objs/melange) + (FLG (-open Foo__)) Foo: _build/default/foo $TESTCASE_ROOT/_build/default/.foo.objs/melange) (FLG (-open Foo__)) + Foo: _build/default/foo.ml + $TESTCASE_ROOT/_build/default/.foo.objs/melange) + (FLG (-open Foo__)) Foo__: _build/default/foo__ $TESTCASE_ROOT/_build/default/.foo.objs/melange) + Foo__: _build/default/foo__.ml-gen + $TESTCASE_ROOT/_build/default/.foo.objs/melange) Paths to Melange stdlib appear in B and S entries without melange.emit stanza @@ -54,6 +61,7 @@ Paths to Melange stdlib appear in B and S entries without melange.emit stanza $ dune build @check $ dune ocaml merlin dump-config $PWD | grep -i "$target" $TESTCASE_ROOT/_build/default/.output.mobjs/melange) + $TESTCASE_ROOT/_build/default/.output.mobjs/melange) Dump-dot-merlin includes the melange flags @@ -103,6 +111,28 @@ User ppx flags should appear in merlin config $ dune ocaml merlin dump-config $PWD | grep -v "(B " | grep -v "(S " Bar: _build/default/bar + ((STDLIB /MELC_STDLIB/melange) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/.foo.objs/melange) + (S + $TESTCASE_ROOT) + (FLG (-open Foo)) + (FLG + (-ppx + "$TESTCASE_ROOT/_build/default/.ppx/4128e43a9cfb141a37f547484cc9bf46/ppx.exe + --as-ppx + --cookie + 'library-name="foo"'")) + (FLG + (-w + @1..3@5..28@30..39@43@46..47@49..57@61..62@67@69-40 + -strict-sequence + -strict-formats + -short-paths + -keep-locs + -g))) + Bar: _build/default/bar.ml ((STDLIB /MELC_STDLIB/melange) (EXCLUDE_QUERY_DIR) (B @@ -125,6 +155,27 @@ User ppx flags should appear in merlin config -keep-locs -g))) Foo: _build/default/foo + ((STDLIB /MELC_STDLIB/melange) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/.foo.objs/melange) + (S + $TESTCASE_ROOT) + (FLG + (-ppx + "$TESTCASE_ROOT/_build/default/.ppx/4128e43a9cfb141a37f547484cc9bf46/ppx.exe + --as-ppx + --cookie + 'library-name="foo"'")) + (FLG + (-w + @1..3@5..28@30..39@43@46..47@49..57@61..62@67@69-40 + -strict-sequence + -strict-formats + -short-paths + -keep-locs + -g))) + Foo: _build/default/foo.ml-gen ((STDLIB /MELC_STDLIB/melange) (EXCLUDE_QUERY_DIR) (B @@ -160,3 +211,18 @@ User ppx flags should appear in merlin config -short-paths -keep-locs -g))) + Fooppx: _build/default/fooppx.ml + ((STDLIB /OCAMLC_WHERE) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/.fooppx.objs/byte) + (S + $TESTCASE_ROOT) + (FLG + (-w + @1..3@5..28@30..39@43@46..47@49..57@61..62@67@69-40 + -strict-sequence + -strict-formats + -short-paths + -keep-locs + -g))) diff --git a/test/blackbox-tests/test-cases/melange/virtual_lib_compilation.t/mel.ml b/test/blackbox-tests/test-cases/melange/virtual_lib_compilation.t/mel.ml index d25c15c88fe..f2c68e8e494 100644 --- a/test/blackbox-tests/test-cases/melange/virtual_lib_compilation.t/mel.ml +++ b/test/blackbox-tests/test-cases/melange/virtual_lib_compilation.t/mel.ml @@ -1 +1 @@ -let () = print_endline Vlib_impl.hello +let () = print_endline Vlib.Vlib_impl.hello diff --git a/test/blackbox-tests/test-cases/melange/virtual_lib_compilation.t/ml.ml b/test/blackbox-tests/test-cases/melange/virtual_lib_compilation.t/ml.ml index d25c15c88fe..f2c68e8e494 100644 --- a/test/blackbox-tests/test-cases/melange/virtual_lib_compilation.t/ml.ml +++ b/test/blackbox-tests/test-cases/melange/virtual_lib_compilation.t/ml.ml @@ -1 +1 @@ -let () = print_endline Vlib_impl.hello +let () = print_endline Vlib.Vlib_impl.hello diff --git a/test/blackbox-tests/test-cases/melange/virtual_lib_compilation.t/vlib/dune b/test/blackbox-tests/test-cases/melange/virtual_lib_compilation.t/vlib/dune index b66794a49c3..2794ca8ca96 100644 --- a/test/blackbox-tests/test-cases/melange/virtual_lib_compilation.t/vlib/dune +++ b/test/blackbox-tests/test-cases/melange/virtual_lib_compilation.t/vlib/dune @@ -1,5 +1,4 @@ (library (name vlib) - (wrapped false) (modes :standard melange) (virtual_modules virt)) diff --git a/test/blackbox-tests/test-cases/merlin/alt-context.t b/test/blackbox-tests/test-cases/merlin/alt-context.t new file mode 100644 index 00000000000..4808c567d61 --- /dev/null +++ b/test/blackbox-tests/test-cases/merlin/alt-context.t @@ -0,0 +1,79 @@ +Showcase behavior when passing the `--context` flag to ocaml-merlin + + $ cat >dune-project < (lang dune 3.14) + > EOF + + $ cat > dune-workspace << EOF + > (lang dune 3.14) + > + > (context default) + > + > (context + > (default + > (name alt))) + > EOF + + $ lib1=foo + $ lib2=bar + $ cat >dune < (library + > (name $lib1) + > (modules $lib1) + > (enabled_if (= %{context_name} "default"))) + > (library + > (name $lib2) + > (modules $lib2) + > (enabled_if (= %{context_name} "alt"))) + > EOF + + $ touch $lib1.ml $lib2.ml + + $ dune build + + $ FILE1=$PWD/$lib1.ml + $ FILE2=$PWD/$lib2.ml + +If `generate_merlin_rules` is not used, we can't query anything in alt context +because by default Merlin rules are only created for the default context + + $ printf '(4:File%d:%s)' ${#FILE2} $FILE2 | dune ocaml-merlin | grep -i "$lib2" + ((5:ERROR58:No config found for file bar.ml. Try calling 'dune build'.)) + + $ printf '(4:File%d:%s)' ${#FILE2} $FILE2 | dune ocaml-merlin --context alt | grep -i "$lib2" + ((5:ERROR58:No config found for file bar.ml. Try calling 'dune build'.)) + +Let's use `generate_merlin_rules` to test these commands + + $ cat > dune-workspace << EOF + > (lang dune 3.16) + > + > (context default) + > + > (context + > (default + > (name alt) + > (generate_merlin_rules))) + > EOF + + $ dune build + +Request config for file in alt context without using --context + + $ printf '(4:File%d:%s)' ${#FILE2} $FILE2 | dune ocaml-merlin | grep -i "$lib2" | sed 's/^[^:]*:[^:]*://' + No config found for file bar.ml. Try calling 'dune build'.)) + +Request config for file in alt context using --context + + $ printf '(4:File%d:%s)' ${#FILE2} $FILE2 | dune ocaml-merlin --context alt | dune format-dune-file | grep -i "$lib2" | sed 's/^[^:]*:[^:]*://' + $TESTCASE_ROOT/_build/alt/.bar.objs/byte) + +Request config for default context without using --context + + $ printf '(4:File%d:%s)' ${#FILE1} $FILE1 | dune ocaml-merlin | dune format-dune-file | grep -i "$lib1" | sed 's/^[^:]*:[^:]*://' + $TESTCASE_ROOT/_build/default/.foo.objs/byte) + +Request config for default context using --context + + $ printf '(4:File%d:%s)' ${#FILE1} $FILE1 | dune ocaml-merlin --context alt | dune format-dune-file | grep -i "$lib1" | sed 's/^[^:]*:[^:]*://' + No config found for file foo.ml. Try calling 'dune build'.)) diff --git a/test/blackbox-tests/test-cases/merlin/default-based-context.t/run.t b/test/blackbox-tests/test-cases/merlin/default-based-context.t/run.t index d29e5ee4eee..c0f5f55d8f1 100644 --- a/test/blackbox-tests/test-cases/merlin/default-based-context.t/run.t +++ b/test/blackbox-tests/test-cases/merlin/default-based-context.t/run.t @@ -37,6 +37,21 @@ If Merlin field is absent, default context is chosen -short-paths -keep-locs -g))) + Foo: _build/default/foo.ml + ((STDLIB OPAM_PREFIX) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/.foo.objs/byte) + (S + $TESTCASE_ROOT) + (FLG + (-w + @1..3@5..28@30..39@43@46..47@49..57@61..62-40 + -strict-sequence + -strict-formats + -short-paths + -keep-locs + -g))) If Merlin field is present, this context is chosen @@ -75,3 +90,74 @@ If Merlin field is present, this context is chosen -short-paths -keep-locs -g))) + Foo: _build/cross/foo.ml + ((STDLIB OPAM_PREFIX) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/cross/.foo.objs/byte) + (S + $TESTCASE_ROOT) + (FLG + (-w + @1..3@5..28@30..39@43@46..47@49..57@61..62-40 + -strict-sequence + -strict-formats + -short-paths + -keep-locs + -g))) + +If `generate_merlin_rules` field is present, rules are generated even if merlin +is disabled in that context + + $ cat >dune-workspace < (lang dune 3.16) + > (context (default)) + > (context + > (default + > (name cross) + > (generate_merlin_rules))) + > EOF + + $ dune build + + $ ls -a _build/cross/.merlin-conf + . + .. + lib-foo + + $ ls -a _build/default/.merlin-conf + . + .. + lib-foo + + $ dune ocaml merlin dump-config "$PWD" + Foo: _build/default/foo + ((STDLIB OPAM_PREFIX) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/.foo.objs/byte) + (S + $TESTCASE_ROOT) + (FLG + (-w + @1..3@5..28@30..39@43@46..47@49..57@61..62-40 + -strict-sequence + -strict-formats + -short-paths + -keep-locs + -g))) + Foo: _build/default/foo.ml + ((STDLIB OPAM_PREFIX) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/.foo.objs/byte) + (S + $TESTCASE_ROOT) + (FLG + (-w + @1..3@5..28@30..39@43@46..47@49..57@61..62-40 + -strict-sequence + -strict-formats + -short-paths + -keep-locs + -g))) diff --git a/test/blackbox-tests/test-cases/merlin/dialect.t/dune-project b/test/blackbox-tests/test-cases/merlin/dialect.t/dune-project new file mode 100644 index 00000000000..1bf4647c9b4 --- /dev/null +++ b/test/blackbox-tests/test-cases/merlin/dialect.t/dune-project @@ -0,0 +1,10 @@ +(lang dune 3.16) + +(using melange 0.1) + +(dialect + (name mlx) + (implementation + (extension mlx) + (preprocess (run cat %{input-file})) + (merlin_reader mlx))) diff --git a/test/blackbox-tests/test-cases/merlin/dialect.t/exe/dune b/test/blackbox-tests/test-cases/merlin/dialect.t/exe/dune new file mode 100644 index 00000000000..efd40e79e08 --- /dev/null +++ b/test/blackbox-tests/test-cases/merlin/dialect.t/exe/dune @@ -0,0 +1,2 @@ +(executable + (name x)) diff --git a/test/blackbox-tests/test-cases/merlin/dialect.t/exe/x.mlx b/test/blackbox-tests/test-cases/merlin/dialect.t/exe/x.mlx new file mode 100644 index 00000000000..e69de29bb2d diff --git a/test/blackbox-tests/test-cases/merlin/dialect.t/lib/dune b/test/blackbox-tests/test-cases/merlin/dialect.t/lib/dune new file mode 100644 index 00000000000..caefbf89753 --- /dev/null +++ b/test/blackbox-tests/test-cases/merlin/dialect.t/lib/dune @@ -0,0 +1,2 @@ +(library + (name x)) diff --git a/test/blackbox-tests/test-cases/merlin/dialect.t/lib/x.mlx b/test/blackbox-tests/test-cases/merlin/dialect.t/lib/x.mlx new file mode 100644 index 00000000000..e69de29bb2d diff --git a/test/blackbox-tests/test-cases/merlin/dialect.t/melange/dune b/test/blackbox-tests/test-cases/merlin/dialect.t/melange/dune new file mode 100644 index 00000000000..e7804c2555b --- /dev/null +++ b/test/blackbox-tests/test-cases/merlin/dialect.t/melange/dune @@ -0,0 +1,3 @@ +(library + (modes melange) + (name x_mel)) diff --git a/test/blackbox-tests/test-cases/merlin/dialect.t/melange/x_mel.mlx b/test/blackbox-tests/test-cases/merlin/dialect.t/melange/x_mel.mlx new file mode 100644 index 00000000000..e69de29bb2d diff --git a/test/blackbox-tests/test-cases/merlin/dialect.t/run.t b/test/blackbox-tests/test-cases/merlin/dialect.t/run.t new file mode 100644 index 00000000000..62106c4a9af --- /dev/null +++ b/test/blackbox-tests/test-cases/merlin/dialect.t/run.t @@ -0,0 +1,94 @@ + $ ocamlc_where="$(ocamlc -where)" + $ export BUILD_PATH_PREFIX_MAP="/OCAMLC_WHERE=$ocamlc_where:$BUILD_PATH_PREFIX_MAP" + $ ocamlfind_libs="$(ocamlfind printconf path | while read line; do printf lib=${line}:; done)" + $ export BUILD_PATH_PREFIX_MAP="$ocamlfind_libs:$BUILD_PATH_PREFIX_MAP" + $ melc_compiler="$(which melc)" + $ export BUILD_PATH_PREFIX_MAP="/MELC_COMPILER=$melc_compiler:$BUILD_PATH_PREFIX_MAP" + +CRAM sanitization + $ dune build ./exe/.merlin-conf/exe-x --profile release + $ dune ocaml merlin dump-config $PWD/exe + X: _build/default/exe/x + ((STDLIB /OCAMLC_WHERE) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/exe/.x.eobjs/byte) + (S + $TESTCASE_ROOT/exe) + (FLG (-w -40 -g)) + (SUFFIX ".mlx .mlx")) + X: _build/default/exe/x.mlx + ((STDLIB /OCAMLC_WHERE) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/exe/.x.eobjs/byte) + (S + $TESTCASE_ROOT/exe) + (FLG (-w -40 -g)) + (SUFFIX ".mlx .mlx") + (READER (mlx))) + X: _build/default/exe/x.mlx.mli + ((STDLIB /OCAMLC_WHERE) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/exe/.x.eobjs/byte) + (S + $TESTCASE_ROOT/exe) + (FLG (-w -40 -g)) + (SUFFIX ".mlx .mlx")) + +CRAM sanitization + $ dune build ./lib/.merlin-conf/lib-x --profile release + $ dune ocaml merlin dump-config $PWD/lib + X: _build/default/lib/x + ((STDLIB /OCAMLC_WHERE) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/lib/.x.objs/byte) + (S + $TESTCASE_ROOT/lib) + (FLG (-w -40 -g)) + (SUFFIX ".mlx .mlx") + (READER (mlx))) + X: _build/default/lib/x.mlx + ((STDLIB /OCAMLC_WHERE) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/lib/.x.objs/byte) + (S + $TESTCASE_ROOT/lib) + (FLG (-w -40 -g)) + (SUFFIX ".mlx .mlx") + (READER (mlx))) + +CRAM sanitization + $ dune build ./melange/.merlin-conf/lib-x_mel --profile release + $ dune ocaml merlin dump-config $PWD/melange + X_mel: _build/default/melange/x_mel + ((STDLIB lib/melange/melange) + (EXCLUDE_QUERY_DIR) + (B lib/melange/js/melange) + (B lib/melange/melange) + (B + $TESTCASE_ROOT/_build/default/melange/.x_mel.objs/melange) + (S lib/melange) + (S lib/melange/js) + (S + $TESTCASE_ROOT/melange) + (FLG (-w -40 -g)) + (SUFFIX ".mlx .mlx") + (READER (mlx))) + X_mel: _build/default/melange/x_mel.mlx + ((STDLIB lib/melange/melange) + (EXCLUDE_QUERY_DIR) + (B lib/melange/js/melange) + (B lib/melange/melange) + (B + $TESTCASE_ROOT/_build/default/melange/.x_mel.objs/melange) + (S lib/melange) + (S lib/melange/js) + (S + $TESTCASE_ROOT/melange) + (FLG (-w -40 -g)) + (SUFFIX ".mlx .mlx") + (READER (mlx))) diff --git a/test/blackbox-tests/test-cases/merlin/future-syntax.t b/test/blackbox-tests/test-cases/merlin/future-syntax.t index c9aa4119907..c70ccca2e6f 100644 --- a/test/blackbox-tests/test-cases/merlin/future-syntax.t +++ b/test/blackbox-tests/test-cases/merlin/future-syntax.t @@ -25,3 +25,19 @@ (S $TESTCASE_ROOT) (FLG (-w -40 -g))) + Pp_future_syntax: _build/default/pp_future_syntax.ml + ((STDLIB /OCAMLC_WHERE) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/.pp_future_syntax.eobjs/byte) + (S + $TESTCASE_ROOT) + (FLG (-w -40 -g))) + Pp_future_syntax: _build/default/pp_future_syntax.mli + ((STDLIB /OCAMLC_WHERE) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/.pp_future_syntax.eobjs/byte) + (S + $TESTCASE_ROOT) + (FLG (-w -40 -g))) diff --git a/test/blackbox-tests/test-cases/merlin/github1946.t/run.t b/test/blackbox-tests/test-cases/merlin/github1946.t/run.t index 248f27088e9..ffa28575f75 100644 --- a/test/blackbox-tests/test-cases/merlin/github1946.t/run.t +++ b/test/blackbox-tests/test-cases/merlin/github1946.t/run.t @@ -7,6 +7,20 @@ in the same dune file, but require different ppx specifications $ dune build @all --profile release $ dune ocaml merlin dump-config $PWD Usesppx1: _build/default/usesppx1 + ((STDLIB /OCAMLC_WHERE) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/.usesppx1.objs/byte) + (S + $TESTCASE_ROOT) + (FLG + (-ppx + "$TESTCASE_ROOT/_build/default/.ppx/c152d6ca3c7e1d83471ffdf48bf729ae/ppx.exe + --as-ppx + --cookie + 'library-name="usesppx1"'")) + (FLG (-w -40 -g))) + Usesppx1: _build/default/usesppx1.ml-gen ((STDLIB /OCAMLC_WHERE) (EXCLUDE_QUERY_DIR) (B @@ -34,3 +48,17 @@ in the same dune file, but require different ppx specifications --cookie 'library-name="usesppx2"'")) (FLG (-w -40 -g))) + Usesppx2: _build/default/usesppx2.ml-gen + ((STDLIB /OCAMLC_WHERE) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/.usesppx2.objs/byte) + (S + $TESTCASE_ROOT) + (FLG + (-ppx + "$TESTCASE_ROOT/_build/default/.ppx/d7394c27c5e0f7ad7ab1110d6b092c05/ppx.exe + --as-ppx + --cookie + 'library-name="usesppx2"'")) + (FLG (-w -40 -g))) diff --git a/test/blackbox-tests/test-cases/merlin/github4125.t/run.t b/test/blackbox-tests/test-cases/merlin/github4125.t/run.t index 05645739523..39b8b2fd915 100644 --- a/test/blackbox-tests/test-cases/merlin/github4125.t/run.t +++ b/test/blackbox-tests/test-cases/merlin/github4125.t/run.t @@ -37,3 +37,18 @@ We call `$(opam switch show)` so that this test always uses an existing switch -short-paths -keep-locs -g))) + Foo: _build/cross/foo.ml + ((STDLIB /OCAMLC_WHERE) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/cross/.foo.objs/byte) + (S + $TESTCASE_ROOT) + (FLG + (-w + @1..3@5..28@30..39@43@46..47@49..57@61..62-40 + -strict-sequence + -strict-formats + -short-paths + -keep-locs + -g))) diff --git a/test/blackbox-tests/test-cases/merlin/github759.t/run.t b/test/blackbox-tests/test-cases/merlin/github759.t/run.t index d9c548a4a03..286f4180c8b 100644 --- a/test/blackbox-tests/test-cases/merlin/github759.t/run.t +++ b/test/blackbox-tests/test-cases/merlin/github759.t/run.t @@ -4,6 +4,14 @@ $ dune build foo.cma --profile release $ dune ocaml merlin dump-config $PWD Foo: _build/default/foo + ((STDLIB /OCAMLC_WHERE) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/.foo.objs/byte) + (S + $TESTCASE_ROOT) + (FLG (-w -40 -g))) + Foo: _build/default/foo.ml-gen ((STDLIB /OCAMLC_WHERE) (EXCLUDE_QUERY_DIR) (B @@ -16,6 +24,14 @@ $ dune build foo.cma --profile release $ dune ocaml merlin dump-config $PWD Foo: _build/default/foo + ((STDLIB /OCAMLC_WHERE) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/.foo.objs/byte) + (S + $TESTCASE_ROOT) + (FLG (-w -40 -g))) + Foo: _build/default/foo.ml-gen ((STDLIB /OCAMLC_WHERE) (EXCLUDE_QUERY_DIR) (B @@ -35,3 +51,11 @@ (S $TESTCASE_ROOT) (FLG (-w -40 -g))) + Foo: _build/default/foo.ml-gen + ((STDLIB /OCAMLC_WHERE) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/.foo.objs/byte) + (S + $TESTCASE_ROOT) + (FLG (-w -40 -g))) diff --git a/test/blackbox-tests/test-cases/merlin/granularity.t b/test/blackbox-tests/test-cases/merlin/granularity.t new file mode 100644 index 00000000000..ec8bdb63cd1 --- /dev/null +++ b/test/blackbox-tests/test-cases/merlin/granularity.t @@ -0,0 +1,213 @@ + $ ocamlc_where="$(ocamlc -where)" + $ export BUILD_PATH_PREFIX_MAP="/OCAMLC_WHERE=$ocamlc_where:$BUILD_PATH_PREFIX_MAP" + +A utility to query merlin configuration for a file: + $ cat >merlin_conf.sh < #!/bin/sh + > FILE=\$1 + > printf "(4:File%d:%s)" \${#FILE} \$FILE | dune ocaml-merlin \ + > | sed -E "s/[[:digit:]]+:/\?:/g" | sed -E "s/\)(\(+)/\n\1/g" + > EOF + + $ chmod a+x merlin_conf.sh + +Project sources + + $ cat >dune-project < (lang dune 3.16) + > (using melange 0.1) + > + > (dialect + > (name mlx) + > (implementation + > (extension mlx) + > (preprocess (run cat %{input-file})) + > (merlin_reader mlx))) + > EOF + + $ cat >pp.sh < #!/bin/sh + > sed 's/%INT%/42/g' \$1 + > EOF + + $ chmod a+x pp.sh + + $ cat >dune < (executable + > (name test) + > (flags :standard -no-strict-formats) + > (preprocess + > (per_module + > ((action (run ./pp.sh %{input-file})) pped)))) + > + > (rule + > (action (copy cppomod.cppo.ml cppomod.ml))) + > + > (rule + > (action (copy wrongext.cppo.cml wrongext.ml))) + > + > (rule + > (target generatedx.mlx) + > (mode promote) + > (action (with-stdout-to %{target} (echo "let x = \"Generatedx!\"")))) + > + > (rule + > (target generated.ml) + > (mode promote) + > (action (with-stdout-to %{target} (echo "let x = \"Generated!\"")))) + > EOF + + $ cat >test.ml < print_endline Pped.x_42;; + > print_endline Mel.x;; + > print_endline Cppomod.x;; + > print_endline Wrongext.x;; + > print_endline Generated.x;; + > EOF + +Both Pped's ml and mli files will be preprocessed + $ cat >pped.mli < val x_%INT% : string + > EOF + + $ cat >pped.ml < let x_42 = "%INT%" + > EOF + +Melange module signature + $ cat >mel.mli < val x : string + > EOF + +Melange module implementation in Melange syntax + $ cat >mel.mlx < let x = "43" + > EOF + +A pped file with unconventionnal filename + $ cat >cppomod.cppo.ml < let x = "44" + > EOF + + $ cat >wrongext.cppo.cml < let x = "45" + > EOF + + $ dune build @check + $ dune exec ./test.exe + 42 + 43 + 44 + 45 + Generated! + +We now query Merlin configuration for the various source files: + +Some configuration fields are common to all the modules of a same stanza. This +is the case for the stdlib, build and sources directories, flags and suffixes. + +Some configuration can be specific to a module like preprocessing. + +Dialects are specified by extensions so are specific to a file. This means a +different reader might be used for the signature and the implementation. + +Note that Merlin should always be told about dialect-provided suffixes, to make `MerlinLocate` work correctly. + +Preprocessing: + +Is it expected that the suffix for implementation and interface is the same ? + $ ./merlin_conf.sh pped.ml | tee pped.out + ((?:STDLIB?:/OCAMLC_WHERE + (?:EXCLUDE_QUERY_DIR + (?:B?:$TESTCASE_ROOT/_build/default/.test.eobjs/byte + (?:S?:$TESTCASE_ROOT + (?:FLG(?:-open?:Dune__exe) + (?:FLG(?:-pp?:$TESTCASE_ROOT/_build/default/pp.sh) + (?:FLG(?:-w?:@1..3@5..28@31..39@43@46..47@49..57@61..62@67@69-?:-strict-sequence?:-strict-formats?:-short-paths?:-keep-locs?:-no-strict-formats?:-g) + (?:SUFFIX?:.mlx .mlx)) + + $ ./merlin_conf.sh pped.mli | diff pped.out - + +Melange: + +As expected, the reader is not communicated for the standard mli + $ ./merlin_conf.sh mel.mli | tee mel.out + ((?:STDLIB?:/OCAMLC_WHERE + (?:EXCLUDE_QUERY_DIR + (?:B?:$TESTCASE_ROOT/_build/default/.test.eobjs/byte + (?:S?:$TESTCASE_ROOT + (?:FLG(?:-open?:Dune__exe) + (?:FLG(?:-w?:@1..3@5..28@31..39@43@46..47@49..57@61..62@67@69-?:-strict-sequence?:-strict-formats?:-short-paths?:-keep-locs?:-no-strict-formats?:-g) + (?:SUFFIX?:.mlx .mlx)) + +The reader is set for the mlx file + $ ./merlin_conf.sh mel.mlx | diff mel.out - + 7c7,8 + < (?:SUFFIX?:.mlx .mlx)) + \ No newline at end of file + --- + > (?:SUFFIX?:.mlx .mlx + > (?:READER(?:mlx))) + \ No newline at end of file + [1] + +Unconventional file names: + +Users might have preprocessing steps that start with a non-conventional +filename like `mymodule.cppo.ml`. + +While Dune first tries to match by the exact filename requested, if nothing is +found, then it'll make a guess that the file was preprocessed into a file with +.ml extension: + + $ ./merlin_conf.sh cppomod.cppo.ml | tee cppomod.out + ((?:STDLIB?:/OCAMLC_WHERE + (?:EXCLUDE_QUERY_DIR + (?:B?:$TESTCASE_ROOT/_build/default/.test.eobjs/byte + (?:S?:$TESTCASE_ROOT + (?:FLG(?:-open?:Dune__exe) + (?:FLG(?:-w?:@1..3@5..28@31..39@43@46..47@49..57@61..62@67@69-?:-strict-sequence?:-strict-formats?:-short-paths?:-keep-locs?:-no-strict-formats?:-g) + (?:SUFFIX?:.mlx .mlx)) + + $ ./merlin_conf.sh cppomod.ml | diff cppomod.out - + +Note that this means unrelated files might be given the same configuration: + + $ ./merlin_conf.sh cppomod.tralala.ml | diff cppomod.out - + +And with unconventional extension: +(note that without appropriate suffix configuration Merlin will never jump to +such files) +We could expect dune to get the wrongext module configuration + $ ./merlin_conf.sh wrongext.cppo.cml | tee wrongext.out + ((?:STDLIB?:/OCAMLC_WHERE + (?:EXCLUDE_QUERY_DIR + (?:B?:$TESTCASE_ROOT/_build/default/.test.eobjs/byte + (?:S?:$TESTCASE_ROOT + (?:FLG(?:-open?:Dune__exe) + (?:FLG(?:-w?:@1..3@5..28@31..39@43@46..47@49..57@61..62@67@69-?:-strict-sequence?:-strict-formats?:-short-paths?:-keep-locs?:-no-strict-formats?:-g) + (?:SUFFIX?:.mlx .mlx)) + +We also have generated.ml and generatedx.mlx promoted: + $ ls -1 . | grep generated + generated.ml + generatedx.mlx + +It should be possible to get its merlin configuration as well: + $ ./merlin_conf.sh generated.ml + ((?:STDLIB?:/OCAMLC_WHERE + (?:EXCLUDE_QUERY_DIR + (?:B?:$TESTCASE_ROOT/_build/default/.test.eobjs/byte + (?:S?:$TESTCASE_ROOT + (?:FLG(?:-open?:Dune__exe) + (?:FLG(?:-w?:@1..3@5..28@31..39@43@46..47@49..57@61..62@67@69-?:-strict-sequence?:-strict-formats?:-short-paths?:-keep-locs?:-no-strict-formats?:-g) + (?:SUFFIX?:.mlx .mlx)) + $ ./merlin_conf.sh generatedx.mlx + ((?:STDLIB?:/OCAMLC_WHERE + (?:EXCLUDE_QUERY_DIR + (?:B?:$TESTCASE_ROOT/_build/default/.test.eobjs/byte + (?:S?:$TESTCASE_ROOT + (?:FLG(?:-open?:Dune__exe) + (?:FLG(?:-w?:@1..3@5..28@31..39@43@46..47@49..57@61..62@67@69-?:-strict-sequence?:-strict-formats?:-short-paths?:-keep-locs?:-no-strict-formats?:-g) + (?:SUFFIX?:.mlx .mlx + (?:READER(?:mlx))) diff --git a/test/blackbox-tests/test-cases/merlin/include-subdirs-qualified.t b/test/blackbox-tests/test-cases/merlin/include-subdirs-qualified.t index 9a1847ad0ac..834f28c3694 100644 --- a/test/blackbox-tests/test-cases/merlin/include-subdirs-qualified.t +++ b/test/blackbox-tests/test-cases/merlin/include-subdirs-qualified.t @@ -22,6 +22,25 @@ $ dune build .merlin-conf/lib-foo $ dune ocaml merlin dump-config . Foo: _build/default/foo + ((STDLIB /OPAM_PREFIX) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/.foo.objs/byte) + (S + $TESTCASE_ROOT) + (S + $TESTCASE_ROOT/groupintf) + (S + $TESTCASE_ROOT/utils) + (FLG + (-w + @1..3@5..28@30..39@43@46..47@49..57@61..62@67@69-40 + -strict-sequence + -strict-formats + -short-paths + -keep-locs + -g))) + Foo: _build/default/foo.ml-gen ((STDLIB /OPAM_PREFIX) (EXCLUDE_QUERY_DIR) (B @@ -41,6 +60,25 @@ -keep-locs -g))) Foo__Groupintf__: _build/default/foo__Groupintf__ + ((STDLIB /OPAM_PREFIX) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/.foo.objs/byte) + (S + $TESTCASE_ROOT) + (S + $TESTCASE_ROOT/groupintf) + (S + $TESTCASE_ROOT/utils) + (FLG + (-w + @1..3@5..28@30..39@43@46..47@49..57@61..62@67@69-40 + -strict-sequence + -strict-formats + -short-paths + -keep-locs + -g))) + Foo__Groupintf__: _build/default/foo__Groupintf__.ml-gen ((STDLIB /OPAM_PREFIX) (EXCLUDE_QUERY_DIR) (B @@ -60,6 +98,25 @@ -keep-locs -g))) Utils: _build/default/foo__Utils + ((STDLIB /OPAM_PREFIX) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/.foo.objs/byte) + (S + $TESTCASE_ROOT) + (S + $TESTCASE_ROOT/groupintf) + (S + $TESTCASE_ROOT/utils) + (FLG + (-w + @1..3@5..28@30..39@43@46..47@49..57@61..62@67@69-40 + -strict-sequence + -strict-formats + -short-paths + -keep-locs + -g))) + Utils: _build/default/foo__Utils.ml-gen ((STDLIB /OPAM_PREFIX) (EXCLUDE_QUERY_DIR) (B @@ -79,6 +136,26 @@ -keep-locs -g))) Calc: _build/default/groupintf/calc + ((STDLIB /OPAM_PREFIX) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/.foo.objs/byte) + (S + $TESTCASE_ROOT) + (S + $TESTCASE_ROOT/groupintf) + (S + $TESTCASE_ROOT/utils) + (FLG (-open Foo__Groupintf__ -open Foo)) + (FLG + (-w + @1..3@5..28@30..39@43@46..47@49..57@61..62@67@69-40 + -strict-sequence + -strict-formats + -short-paths + -keep-locs + -g))) + Calc: _build/default/groupintf/calc.ml ((STDLIB /OPAM_PREFIX) (EXCLUDE_QUERY_DIR) (B @@ -99,6 +176,26 @@ -keep-locs -g))) Groupintf: _build/default/groupintf/groupintf + ((STDLIB /OPAM_PREFIX) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/.foo.objs/byte) + (S + $TESTCASE_ROOT) + (S + $TESTCASE_ROOT/groupintf) + (S + $TESTCASE_ROOT/utils) + (FLG (-open Foo__Groupintf__ -open Foo)) + (FLG + (-w + @1..3@5..28@30..39@43@46..47@49..57@61..62@67@69-40 + -strict-sequence + -strict-formats + -short-paths + -keep-locs + -g))) + Groupintf: _build/default/groupintf/groupintf.ml ((STDLIB /OPAM_PREFIX) (EXCLUDE_QUERY_DIR) (B @@ -119,6 +216,26 @@ -keep-locs -g))) Main: _build/default/main + ((STDLIB /OPAM_PREFIX) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/.foo.objs/byte) + (S + $TESTCASE_ROOT) + (S + $TESTCASE_ROOT/groupintf) + (S + $TESTCASE_ROOT/utils) + (FLG (-open Foo)) + (FLG + (-w + @1..3@5..28@30..39@43@46..47@49..57@61..62@67@69-40 + -strict-sequence + -strict-formats + -short-paths + -keep-locs + -g))) + Main: _build/default/main.ml ((STDLIB /OPAM_PREFIX) (EXCLUDE_QUERY_DIR) (B @@ -139,6 +256,26 @@ -keep-locs -g))) Calc: _build/default/utils/calc + ((STDLIB /OPAM_PREFIX) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/.foo.objs/byte) + (S + $TESTCASE_ROOT) + (S + $TESTCASE_ROOT/groupintf) + (S + $TESTCASE_ROOT/utils) + (FLG (-open Foo__Utils -open Foo)) + (FLG + (-w + @1..3@5..28@30..39@43@46..47@49..57@61..62@67@69-40 + -strict-sequence + -strict-formats + -short-paths + -keep-locs + -g))) + Calc: _build/default/utils/calc.ml ((STDLIB /OPAM_PREFIX) (EXCLUDE_QUERY_DIR) (B diff --git a/test/blackbox-tests/test-cases/merlin/instrumentation.t/run.t b/test/blackbox-tests/test-cases/merlin/instrumentation.t/run.t index 7a94d814404..2fea5f64a9f 100644 --- a/test/blackbox-tests/test-cases/merlin/instrumentation.t/run.t +++ b/test/blackbox-tests/test-cases/merlin/instrumentation.t/run.t @@ -9,6 +9,20 @@ up a project with instrumentation and testing checking the merlin config. $ dune build --instrument-with hello ./lib/.merlin-conf/lib-foo ./lib/.merlin-conf/lib-bar --profile release $ dune ocaml merlin dump-config $PWD/lib Bar: _build/default/lib/bar + ((STDLIB /OCAMLC_WHERE) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/lib/.bar.objs/byte) + (B + $TESTCASE_ROOT/_build/default/ppx/.hello.objs/byte) + (S + $TESTCASE_ROOT/lib) + (S + $TESTCASE_ROOT/lib/subdir) + (S + $TESTCASE_ROOT/ppx) + (FLG (-w -40 -g))) + Bar: _build/default/lib/bar.ml-gen ((STDLIB /OCAMLC_WHERE) (EXCLUDE_QUERY_DIR) (B @@ -23,6 +37,21 @@ up a project with instrumentation and testing checking the merlin config. $TESTCASE_ROOT/ppx) (FLG (-w -40 -g))) File: _build/default/lib/subdir/file + ((STDLIB /OCAMLC_WHERE) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/lib/.bar.objs/byte) + (B + $TESTCASE_ROOT/_build/default/ppx/.hello.objs/byte) + (S + $TESTCASE_ROOT/lib) + (S + $TESTCASE_ROOT/lib/subdir) + (S + $TESTCASE_ROOT/ppx) + (FLG (-open Bar)) + (FLG (-w -40 -g))) + File: _build/default/lib/subdir/file.ml ((STDLIB /OCAMLC_WHERE) (EXCLUDE_QUERY_DIR) (B @@ -38,6 +67,20 @@ up a project with instrumentation and testing checking the merlin config. (FLG (-open Bar)) (FLG (-w -40 -g))) Foo: _build/default/lib/foo + ((STDLIB /OCAMLC_WHERE) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/lib/.foo.objs/byte) + (B + $TESTCASE_ROOT/_build/default/ppx/.hello.objs/byte) + (S + $TESTCASE_ROOT/lib) + (S + $TESTCASE_ROOT/lib/subdir) + (S + $TESTCASE_ROOT/ppx) + (FLG (-w -40 -g))) + Foo: _build/default/lib/foo.ml-gen ((STDLIB /OCAMLC_WHERE) (EXCLUDE_QUERY_DIR) (B @@ -66,3 +109,18 @@ up a project with instrumentation and testing checking the merlin config. $TESTCASE_ROOT/ppx) (FLG (-open Foo)) (FLG (-w -40 -g))) + Privmod: _build/default/lib/privmod.ml + ((STDLIB /OCAMLC_WHERE) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/lib/.foo.objs/byte) + (B + $TESTCASE_ROOT/_build/default/ppx/.hello.objs/byte) + (S + $TESTCASE_ROOT/lib) + (S + $TESTCASE_ROOT/lib/subdir) + (S + $TESTCASE_ROOT/ppx) + (FLG (-open Foo)) + (FLG (-w -40 -g))) diff --git a/test/blackbox-tests/test-cases/merlin/merlin-from-subdir.t/run.t b/test/blackbox-tests/test-cases/merlin/merlin-from-subdir.t/run.t index b3aab326d86..3895364d430 100644 --- a/test/blackbox-tests/test-cases/merlin/merlin-from-subdir.t/run.t +++ b/test/blackbox-tests/test-cases/merlin/merlin-from-subdir.t/run.t @@ -8,6 +8,25 @@ We build the project Verify that merlin configuration was generated... $ dune ocaml merlin dump-config $PWD Test: _build/default/test + ((STDLIB /OCAMLC_WHERE) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/.foo.objs/byte) + (B + $TESTCASE_ROOT/_build/default/.test.eobjs/byte) + (S + $TESTCASE_ROOT) + (S + $TESTCASE_ROOT/411) + (FLG + (-w + @1..3@5..28@30..39@43@46..47@49..57@61..62-40 + -strict-sequence + -strict-formats + -short-paths + -keep-locs + -g))) + Test: _build/default/test.ml ((STDLIB /OCAMLC_WHERE) (EXCLUDE_QUERY_DIR) (B @@ -43,6 +62,23 @@ Verify that merlin configuration was generated... -short-paths -keep-locs -g))) + Foo: _build/default/foo.ml + ((STDLIB /OCAMLC_WHERE) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/.foo.objs/byte) + (S + $TESTCASE_ROOT) + (S + $TESTCASE_ROOT/411) + (FLG + (-w + @1..3@5..28@30..39@43@46..47@49..57@61..62-40 + -strict-sequence + -strict-formats + -short-paths + -keep-locs + -g))) ...but not in the sub-folder whose content was copied $ dune ocaml merlin dump-config $PWD/411 diff --git a/test/blackbox-tests/test-cases/merlin/merlin-tests.t/run.t b/test/blackbox-tests/test-cases/merlin/merlin-tests.t/run.t index ed506bb77df..c164517d918 100644 --- a/test/blackbox-tests/test-cases/merlin/merlin-tests.t/run.t +++ b/test/blackbox-tests/test-cases/merlin/merlin-tests.t/run.t @@ -14,6 +14,25 @@ CRAM sanitization $ dune build ./exe/.merlin-conf/exe-x --profile release $ dune ocaml merlin dump-config $PWD/exe X: _build/default/exe/x + ((STDLIB /OCAMLC_WHERE) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_findlib/publicfoo) + (B + $TESTCASE_ROOT/_build/default/exe/.x.eobjs/byte) + (B + $TESTCASE_ROOT/_build/default/lib/.foo.objs/public_cmi) + (S + $TESTCASE_ROOT/_findlib/publicfoo) + (S + $TESTCASE_ROOT/exe) + (S + $TESTCASE_ROOT/lib) + (FLG + (-pp + $TESTCASE_ROOT/_build/default/pp/pp.exe)) + (FLG (-w -40 -g))) + X: _build/default/exe/x.ml ((STDLIB /OCAMLC_WHERE) (EXCLUDE_QUERY_DIR) (B @@ -36,6 +55,22 @@ CRAM sanitization $ dune build ./lib/.merlin-conf/lib-foo ./lib/.merlin-conf/lib-bar --profile release $ dune ocaml merlin dump-config $PWD/lib Bar: _build/default/lib/bar + ((STDLIB /OCAMLC_WHERE) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/lib/.bar.objs/byte) + (S + $TESTCASE_ROOT/lib) + (S + $TESTCASE_ROOT/lib/subdir) + (FLG + (-ppx + "$TESTCASE_ROOT/_build/default/.ppx/4128e43a9cfb141a37f547484cc9bf46/ppx.exe + --as-ppx + --cookie + 'library-name="bar"'")) + (FLG (-w -40 -g))) + Bar: _build/default/lib/bar.ml-gen ((STDLIB /OCAMLC_WHERE) (EXCLUDE_QUERY_DIR) (B @@ -52,6 +87,23 @@ CRAM sanitization 'library-name="bar"'")) (FLG (-w -40 -g))) File: _build/default/lib/subdir/file + ((STDLIB /OCAMLC_WHERE) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/lib/.bar.objs/byte) + (S + $TESTCASE_ROOT/lib) + (S + $TESTCASE_ROOT/lib/subdir) + (FLG (-open Bar)) + (FLG + (-ppx + "$TESTCASE_ROOT/_build/default/.ppx/4128e43a9cfb141a37f547484cc9bf46/ppx.exe + --as-ppx + --cookie + 'library-name="bar"'")) + (FLG (-w -40 -g))) + File: _build/default/lib/subdir/file.ml ((STDLIB /OCAMLC_WHERE) (EXCLUDE_QUERY_DIR) (B @@ -69,6 +121,26 @@ CRAM sanitization 'library-name="bar"'")) (FLG (-w -40 -g))) Foo: _build/default/lib/foo + ((STDLIB /OCAMLC_WHERE) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_findlib/publicfoo) + (B + $TESTCASE_ROOT/_build/default/lib/.foo.objs/byte) + (S + $TESTCASE_ROOT/_findlib/publicfoo) + (S + $TESTCASE_ROOT/lib) + (S + $TESTCASE_ROOT/lib/subdir) + (FLG + (-ppx + "$TESTCASE_ROOT/_build/default/.ppx/4128e43a9cfb141a37f547484cc9bf46/ppx.exe + --as-ppx + --cookie + 'library-name="foo"'")) + (FLG (-w -40 -g))) + Foo: _build/default/lib/foo.ml-gen ((STDLIB /OCAMLC_WHERE) (EXCLUDE_QUERY_DIR) (B @@ -109,6 +181,27 @@ CRAM sanitization --cookie 'library-name="foo"'")) (FLG (-w -40 -g))) + Privmod: _build/default/lib/privmod.ml + ((STDLIB /OCAMLC_WHERE) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_findlib/publicfoo) + (B + $TESTCASE_ROOT/_build/default/lib/.foo.objs/byte) + (S + $TESTCASE_ROOT/_findlib/publicfoo) + (S + $TESTCASE_ROOT/lib) + (S + $TESTCASE_ROOT/lib/subdir) + (FLG (-open Foo)) + (FLG + (-ppx + "$TESTCASE_ROOT/_build/default/.ppx/4128e43a9cfb141a37f547484cc9bf46/ppx.exe + --as-ppx + --cookie + 'library-name="foo"'")) + (FLG (-w -40 -g))) Make sure a ppx directive is generated (if not, the [grep ppx] step fails) $ dune ocaml merlin dump-config $PWD/lib | grep ppx > /dev/null @@ -129,11 +222,38 @@ Make sure pp flag is correct and variables are expanded "$TESTCASE_ROOT/_build/default/pp/pp.exe -nothing")) (FLG (-w -40 -g))) + Foobar: _build/default/pp-with-expand/foobar.ml + ((STDLIB /OCAMLC_WHERE) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/pp-with-expand/.foobar.eobjs/byte) + (S + $TESTCASE_ROOT/pp-with-expand) + (FLG + (-pp + "$TESTCASE_ROOT/_build/default/pp/pp.exe + -nothing")) + (FLG (-w -40 -g))) Check hash of executables names if more than one $ dune build ./exes/.merlin-conf/exe-x-6562915302827c6dce0630390bfa68b7 $ dune ocaml merlin dump-config $PWD/exes X: _build/default/exes/x + ((STDLIB /OCAMLC_WHERE) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/exes/.x.eobjs/byte) + (S + $TESTCASE_ROOT/exes) + (FLG + (-w + @1..3@5..28@30..39@43@46..47@49..57@61..62-40 + -strict-sequence + -strict-formats + -short-paths + -keep-locs + -g))) + X: _build/default/exes/x.ml ((STDLIB /OCAMLC_WHERE) (EXCLUDE_QUERY_DIR) (B @@ -163,3 +283,18 @@ Check hash of executables names if more than one -short-paths -keep-locs -g))) + Y: _build/default/exes/y.ml + ((STDLIB /OCAMLC_WHERE) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/exes/.x.eobjs/byte) + (S + $TESTCASE_ROOT/exes) + (FLG + (-w + @1..3@5..28@30..39@43@46..47@49..57@61..62-40 + -strict-sequence + -strict-formats + -short-paths + -keep-locs + -g))) diff --git a/test/blackbox-tests/test-cases/merlin/per-module-pp.t/run.t b/test/blackbox-tests/test-cases/merlin/per-module-pp.t/run.t index bc757674273..532a2f258a7 100644 --- a/test/blackbox-tests/test-cases/merlin/per-module-pp.t/run.t +++ b/test/blackbox-tests/test-cases/merlin/per-module-pp.t/run.t @@ -8,6 +8,21 @@ should appear only once since only Foo is using it. $ dune ocaml merlin dump-config $PWD Bar: _build/default/bar + ((STDLIB /OCAMLC_WHERE) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/.foo.objs/byte) + (S + $TESTCASE_ROOT) + (FLG + (-w + @1..3@5..28@30..39@43@46..47@49..57@61..62-40 + -strict-sequence + -strict-formats + -short-paths + -keep-locs + -g))) + Bar: _build/default/bar.ml ((STDLIB /OCAMLC_WHERE) (EXCLUDE_QUERY_DIR) (B @@ -40,3 +55,21 @@ should appear only once since only Foo is using it. -short-paths -keep-locs -g))) + Foo: _build/default/foo.ml + ((STDLIB /OCAMLC_WHERE) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/.foo.objs/byte) + (S + $TESTCASE_ROOT) + (FLG + (-pp + $TESTCASE_ROOT/_build/default/pp/pp.exe)) + (FLG + (-w + @1..3@5..28@30..39@43@46..47@49..57@61..62-40 + -strict-sequence + -strict-formats + -short-paths + -keep-locs + -g))) diff --git a/test/blackbox-tests/test-cases/merlin/src-dirs-of-deps.t b/test/blackbox-tests/test-cases/merlin/src-dirs-of-deps.t index 9b5eb4152a5..178fccc1c7b 100644 --- a/test/blackbox-tests/test-cases/merlin/src-dirs-of-deps.t +++ b/test/blackbox-tests/test-cases/merlin/src-dirs-of-deps.t @@ -43,3 +43,24 @@ library also has more than one src dir. -short-paths -keep-locs -g))) + Lib2: _build/default/lib2/lib2.ml-gen + ((STDLIB /OPAM_PREFIX) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/lib1/.lib1.objs/byte) + (B + $TESTCASE_ROOT/_build/default/lib2/.lib2.objs/byte) + (S + $TESTCASE_ROOT/lib1) + (S + $TESTCASE_ROOT/lib1/sub) + (S + $TESTCASE_ROOT/lib2) + (FLG + (-w + @1..3@5..28@30..39@43@46..47@49..57@61..62-40 + -strict-sequence + -strict-formats + -short-paths + -keep-locs + -g))) diff --git a/test/blackbox-tests/test-cases/merlin/suffix.t/run.t b/test/blackbox-tests/test-cases/merlin/suffix.t/run.t index 159ba87fd27..9e3e0002406 100644 --- a/test/blackbox-tests/test-cases/merlin/suffix.t/run.t +++ b/test/blackbox-tests/test-cases/merlin/suffix.t/run.t @@ -3,3 +3,5 @@ $ dune ocaml merlin dump-config $PWD | grep SUFFIX (SUFFIX ".aml .amli") (SUFFIX ".baml .bamli")) + (SUFFIX ".aml .amli") + (SUFFIX ".baml .bamli")) 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 index 80e7b75a08b..0a181e434b2 100644 --- 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 @@ -6,6 +6,25 @@ $ dune ocaml merlin dump-config $PWD Foo: _build/default/foo + ((STDLIB /OCAMLC_WHERE) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/.foo.eobjs/byte) + (B + $TESTCASE_ROOT/_build/default/foo/.foo.objs/byte) + (S + $TESTCASE_ROOT) + (S + $TESTCASE_ROOT/foo) + (FLG + (-w + @1..3@5..28@30..39@43@46..47@49..57@61..62-40 + -strict-sequence + -strict-formats + -short-paths + -keep-locs + -g))) + Foo: _build/default/foo.ml ((STDLIB /OCAMLC_WHERE) (EXCLUDE_QUERY_DIR) (B @@ -27,6 +46,22 @@ $ dune ocaml merlin dump-config $PWD/foo Bar: _build/default/foo/bar + ((STDLIB /OCAMLC_WHERE) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/foo/.foo.objs/byte) + (S + $TESTCASE_ROOT/foo) + (FLG (-open Foo)) + (FLG + (-w + @1..3@5..28@30..39@43@46..47@49..57@61..62-40 + -strict-sequence + -strict-formats + -short-paths + -keep-locs + -g))) + Bar: _build/default/foo/bar.ml ((STDLIB /OCAMLC_WHERE) (EXCLUDE_QUERY_DIR) (B @@ -57,6 +92,21 @@ -short-paths -keep-locs -g))) + Foo: _build/default/foo/foo.ml-gen + ((STDLIB /OCAMLC_WHERE) + (EXCLUDE_QUERY_DIR) + (B + $TESTCASE_ROOT/_build/default/foo/.foo.objs/byte) + (S + $TESTCASE_ROOT/foo) + (FLG + (-w + @1..3@5..28@30..39@43@46..47@49..57@61..62-40 + -strict-sequence + -strict-formats + -short-paths + -keep-locs + -g))) FIXME : module Foo is not unbound This test is disabled because it depends on root detection and is not reproducible. diff --git a/test/blackbox-tests/test-cases/pkg/checksum-local-archive.t b/test/blackbox-tests/test-cases/pkg/checksum-local-archive.t new file mode 100644 index 00000000000..d44698d929d --- /dev/null +++ b/test/blackbox-tests/test-cases/pkg/checksum-local-archive.t @@ -0,0 +1,23 @@ +Make sure that we verify archives of local archives + + $ . ./helpers.sh + + $ make_lockdir + + $ touch foo.tar.gz + + $ make_lockpkg foo < (version 0.0.1) + > (source + > (fetch + > (checksum md5=069aa55d40e548280f92af693f6c625a) + > (url $PWD/foo.tar.gz))) + > EOF + + $ build_pkg foo + File "dune.lock/foo.pkg", line 4, characters 12-48: + 4 | (checksum md5=069aa55d40e548280f92af693f6c625a) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + Error: Invalid checksum, got + md5=069aa55d40e548280f92af693f6c625a + [1] diff --git a/test/blackbox-tests/test-cases/pkg/opam-package-with-setenv.t b/test/blackbox-tests/test-cases/pkg/opam-package-with-setenv.t index 6dfc56906d0..ebb1cca955c 100644 --- a/test/blackbox-tests/test-cases/pkg/opam-package-with-setenv.t +++ b/test/blackbox-tests/test-cases/pkg/opam-package-with-setenv.t @@ -57,6 +57,14 @@ The exported env from the first package should be in the lock dir. When building the second package the exported env vars from the first package should be available and all the env updates should be applied correctly. +The output of opam when building the equivalent package is: + +Hello from the other package! +Prepended without trailing sep +Prepended with trailing sep: +Appended without leading sep +:Appended with leading sep + $ EXPORTED_ENV_VAR="I have not been exported yet." \ > prepend_without_trailing_sep="foo:bar" \ > prepend_with_trailing_sep="foo:bar" \ @@ -102,6 +110,15 @@ We can now observe how the environment updates are applied a second time. We currently have the following issues: - The leading and trailing separators are missing. - The initial environment is missing. +- The order of applying environment updates is different from opam's. + +The output of opam when building the equivalent package is: + +Hello from the other package! +Prepended without trailing sep:Prepended 2nd time without trailing sep +Prepended with trailing sep:Prepended 2nd time with sep: +Appended 2nd time without leading sep:Appended without leading sep +:Appended 2nd time with leading sep:Appended with leading sep $ EXPORTED_ENV_VAR="I have not been exported yet." \ > prepend_without_trailing_sep="foo:bar" \ diff --git a/test/blackbox-tests/test-cases/version-corruption.t b/test/blackbox-tests/test-cases/version-corruption.t old mode 100755 new mode 100644 index c1ac480b550..93156474483 --- a/test/blackbox-tests/test-cases/version-corruption.t +++ b/test/blackbox-tests/test-cases/version-corruption.t @@ -1,18 +1,25 @@ -Define a helper ./dump.sh unction with offsets removed, and one byte per line in -hex (so that the output is compiler version / alignment independent). +Define a helper program that counts how many bytes differ between two files. - $ cat >./dump.sh <<'EOF' - > set -eu - > od -v -A n -t x1 $1 | tr ' ' '\n' | sed '/^$/d' + $ cat > compare.ml << EOF + > let count_different_bytes s1 s2 = + > if String.length s1 <> String.length s2 then + > failwith "This test is only meaningful for files with the same length"; + > let c = ref 0 in + > String.iteri (fun i c1 -> + > let c2 = String.unsafe_get s2 i in + > if not (Char.equal c1 c2) then + > incr c; + > ) s1; + > !c + > + > let read_all path = In_channel.with_open_bin path In_channel.input_all + > + > let () = + > let s1 = read_all Sys.argv.(1) in + > let s2 = read_all Sys.argv.(2) in + > let n = count_different_bytes s1 s2 in + > Printf.printf "%d\n" n > EOF - $ chmod +x ./dump.sh - $ cat >./compare.sh <<'EOF' - > set -eu - > ./dump.sh $1 >$1.dump - > ./dump.sh $2 >$2.dump - > cmp -l $1.dump $2.dump | wc -l | sed -e 's/^ *//' - > EOF - $ chmod +x compare.sh A repro that builds and installs multiple binaries, and promotes a bytecode and native executable in same rule (this is very likely to detect corruption with @@ -97,12 +104,15 @@ shared buffer): $ rm -f gen_lifecycle.bc gen_lifecycle.exe && dune clean && dune build && ./gen_lifecycle.exe >/dev/null $ cp _build/default/gen_lifecycle.exe gen_lifecycle.old +We compare the substituted version with the original. The expected value is 64, +which corresponds to `~min_len` in Link_time_code_gen. + $ dune install -j16 --prefix=./_install - $ ./compare.sh _build/default/gen1.exe _install/bin/gen1 - 100 + $ ocaml ./compare.ml _build/default/gen1.exe _install/bin/gen1 + 64 - $ ./compare.sh _build/default/gen2.bc _install/bin/gen2 - 100 + $ ocaml compare.ml _build/default/gen2.bc _install/bin/gen2 + 64 $ dune build --debug-artifact-substitution Found placeholder in _build/default/gen_lifecycle.exe: @@ -112,8 +122,8 @@ shared buffer): - placeholder: Vcs_describe In_source_tree "." - evaluates to: "v0.0.1" - $ ./compare.sh gen_lifecycle.old ./gen_lifecycle.exe - 100 + $ ocaml compare.ml gen_lifecycle.old ./gen_lifecycle.exe + 64 $ ./gen_lifecycle.exe 0.0.1 diff --git a/test/blackbox-tests/test-cases/workspaces/custom-context-names.t b/test/blackbox-tests/test-cases/workspaces/custom-context-names.t new file mode 100644 index 00000000000..048b61d2fea --- /dev/null +++ b/test/blackbox-tests/test-cases/workspaces/custom-context-names.t @@ -0,0 +1,27 @@ + + $ cat > dune-workspace << EOF + > (lang dune 3.13) + > (context default) + > (context + > (default + > (name log))) + > EOF + + $ dune build + File "dune-workspace", line 5, characters 8-11: + 5 | (name log))) + ^^^ + Error: "log" is an invalid context name. + [1] + + $ cat > dune-workspace << EOF + > (lang dune 3.13) + > (context default) + > (context + > (default + > (name install))) + > EOF + $ dune build 2>&1 | grep "must not crash" + I must not crash. Uncertainty is the mind-killer. Exceptions are the + + diff --git a/test/expect-tests/csexp_rpc/csexp_rpc_tests.ml b/test/expect-tests/csexp_rpc/csexp_rpc_tests.ml index 76e5f754120..ef3b6298611 100644 --- a/test/expect-tests/csexp_rpc/csexp_rpc_tests.ml +++ b/test/expect-tests/csexp_rpc/csexp_rpc_tests.ml @@ -91,8 +91,7 @@ let%expect_test "csexp server life cycle" = let config = { Scheduler.Config.concurrency = 1 ; stats = None - ; insignificant_changes = `React - ; signal_watcher = `No + ; print_ctrl_c_warning = false ; watch_exclusions = [] } in diff --git a/test/expect-tests/dune_async_io/async_io_tests.ml b/test/expect-tests/dune_async_io/async_io_tests.ml index b5923856c1e..4cd084f9d33 100644 --- a/test/expect-tests/dune_async_io/async_io_tests.ml +++ b/test/expect-tests/dune_async_io/async_io_tests.ml @@ -6,8 +6,7 @@ open Dune_async_io let config = { Scheduler.Config.concurrency = 1 ; stats = None - ; insignificant_changes = `Ignore - ; signal_watcher = `No + ; print_ctrl_c_warning = false ; watch_exclusions = [] } ;; diff --git a/test/expect-tests/dune_patch/dune_patch_tests.ml b/test/expect-tests/dune_patch/dune_patch_tests.ml index 80078eafd45..26aa926b418 100644 --- a/test/expect-tests/dune_patch/dune_patch_tests.ml +++ b/test/expect-tests/dune_patch/dune_patch_tests.ml @@ -87,8 +87,7 @@ let test files (patch, patch_contents) = let config = { Scheduler.Config.concurrency = 1 ; stats = None - ; insignificant_changes = `Ignore - ; signal_watcher = `No + ; print_ctrl_c_warning = false ; watch_exclusions = [] } in diff --git a/test/expect-tests/dune_pkg/dune_pkg_unit_tests.ml b/test/expect-tests/dune_pkg/dune_pkg_unit_tests.ml index ed4c240c8db..1a76f962a6e 100644 --- a/test/expect-tests/dune_pkg/dune_pkg_unit_tests.ml +++ b/test/expect-tests/dune_pkg/dune_pkg_unit_tests.ml @@ -97,12 +97,7 @@ let lock_dir_encode_decode_round_trip_test ?commit ~lock_dir_path ~lock_dir () = let run thunk = let on_event _config _event = () in let config : Scheduler.Config.t = - { concurrency = 1 - ; stats = None - ; insignificant_changes = `Ignore - ; signal_watcher = `No - ; watch_exclusions = [] - } + { concurrency = 1; stats = None; print_ctrl_c_warning = false; watch_exclusions = [] } in Scheduler.Run.go config ~on_event thunk ;; diff --git a/test/expect-tests/dune_pkg/fetch_tests.ml b/test/expect-tests/dune_pkg/fetch_tests.ml index 1accd06a557..dd80df72a63 100644 --- a/test/expect-tests/dune_pkg/fetch_tests.ml +++ b/test/expect-tests/dune_pkg/fetch_tests.ml @@ -70,12 +70,7 @@ let download ?(reproducible = true) ~unpack ~port ~filename ~target ?checksum () let run thunk = let on_event _config _event = () in let config : Scheduler.Config.t = - { concurrency = 1 - ; stats = None - ; insignificant_changes = `Ignore - ; signal_watcher = `No - ; watch_exclusions = [] - } + { concurrency = 1; stats = None; print_ctrl_c_warning = false; watch_exclusions = [] } in Scheduler.Run.go config ~on_event thunk ;; diff --git a/test/expect-tests/dune_pkg/rev_store_tests.ml b/test/expect-tests/dune_pkg/rev_store_tests.ml index b3ea996e7b4..a0de0f0c8f8 100644 --- a/test/expect-tests/dune_pkg/rev_store_tests.ml +++ b/test/expect-tests/dune_pkg/rev_store_tests.ml @@ -12,12 +12,7 @@ let () = Dune_tests_common.init () let run thunk = let on_event _config _event = () in let config : Scheduler.Config.t = - { concurrency = 1 - ; stats = None - ; insignificant_changes = `Ignore - ; signal_watcher = `No - ; watch_exclusions = [] - } + { concurrency = 1; stats = None; print_ctrl_c_warning = false; watch_exclusions = [] } in Scheduler.Run.go config ~on_event thunk ;; diff --git a/test/expect-tests/dune_rpc_e2e/dune_rpc_e2e.ml b/test/expect-tests/dune_rpc_e2e/dune_rpc_e2e.ml index d6d2f7092f0..1c54cba221c 100644 --- a/test/expect-tests/dune_rpc_e2e/dune_rpc_e2e.ml +++ b/test/expect-tests/dune_rpc_e2e/dune_rpc_e2e.ml @@ -177,8 +177,7 @@ let config = Dune_engine.Clflags.display := Quiet; { Scheduler.Config.concurrency = 1 ; stats = None - ; insignificant_changes = `React - ; signal_watcher = `No + ; print_ctrl_c_warning = false ; watch_exclusions = [] } ;; diff --git a/test/expect-tests/dune_rpc_e2e/dune_rpc_registry_test.ml b/test/expect-tests/dune_rpc_e2e/dune_rpc_registry_test.ml index eb104af7d3a..2991b6a718d 100644 --- a/test/expect-tests/dune_rpc_e2e/dune_rpc_registry_test.ml +++ b/test/expect-tests/dune_rpc_e2e/dune_rpc_registry_test.ml @@ -26,8 +26,7 @@ let run = let config = { Scheduler.Config.concurrency = 1 ; stats = None - ; insignificant_changes = `React - ; signal_watcher = `No + ; print_ctrl_c_warning = false ; watch_exclusions = [] } in diff --git a/test/expect-tests/process_tests.ml b/test/expect-tests/process_tests.ml index 98518410513..35ad3eb6665 100644 --- a/test/expect-tests/process_tests.ml +++ b/test/expect-tests/process_tests.ml @@ -7,8 +7,7 @@ let go = Clflags.display := Short; { Scheduler.Config.concurrency = 1 ; stats = None - ; insignificant_changes = `React - ; signal_watcher = `Yes + ; print_ctrl_c_warning = true ; watch_exclusions = [] } in diff --git a/test/expect-tests/scheduler_tests.ml b/test/expect-tests/scheduler_tests.ml index 815b4108932..f29179f7c51 100644 --- a/test/expect-tests/scheduler_tests.ml +++ b/test/expect-tests/scheduler_tests.ml @@ -9,8 +9,7 @@ let default = Clflags.display := Short; { Scheduler.Config.concurrency = 1 ; stats = None - ; insignificant_changes = `React - ; signal_watcher = `No + ; print_ctrl_c_warning = false ; watch_exclusions = [] } ;; @@ -71,10 +70,7 @@ let%expect_test "cancelling a build: effect on other fibers" = Scheduler.inject_memo_invalidation (Memo.Cell.invalidate cell ~reason:Unknown) in let* () = Scheduler.wait_for_build_input_change () in - let* res = - Fiber.collect_errors (fun () -> - Scheduler.with_job_slot (fun _ _ -> Fiber.return ())) - in + let* res = Fiber.collect_errors (fun () -> Fiber.return ()) in print_endline (match res with | Ok () -> "PASS: we can still run things outside the build" @@ -83,33 +79,6 @@ let%expect_test "cancelling a build: effect on other fibers" = [%expect {| PASS: we can still run things outside the build |}] ;; -let%expect_test "empty invalidation wakes up waiter" = - let test insignificant_changes = - go ~timeout:0.1 ~config:{ default with insignificant_changes } - @@ fun () -> - let await_invalidation () = - print_endline "awaiting invalidation"; - let+ () = Scheduler.wait_for_build_input_change () in - print_endline "awaited invalidation" - in - Fiber.fork_and_join_unit - (fun () -> Scheduler.inject_memo_invalidation Memo.Invalidation.empty) - await_invalidation - in - test `React; - [%expect {| - awaiting invalidation - awaited invalidation |}]; - test `Ignore; - [%expect.unreachable] -[@@expect.uncaught_exn - {| - ("shutdown: timeout") - Trailing output - --------------- - awaiting invalidation |}] -;; - let%expect_test "raise inside Scheduler.Run.go" = (try (go diff --git a/test/expect-tests/timer_tests.ml b/test/expect-tests/timer_tests.ml index b6a5891c2c6..f9e3c33c6dc 100644 --- a/test/expect-tests/timer_tests.ml +++ b/test/expect-tests/timer_tests.ml @@ -6,8 +6,7 @@ let config = Dune_engine.Clflags.display := Short; { Scheduler.Config.concurrency = 1 ; stats = None - ; insignificant_changes = `React - ; signal_watcher = `No + ; print_ctrl_c_warning = false ; watch_exclusions = [] } ;; diff --git a/test/expect-tests/vcs/vcs_tests.ml b/test/expect-tests/vcs/vcs_tests.ml index 71f0fc41604..c44ccb3e2e5 100644 --- a/test/expect-tests/vcs/vcs_tests.ml +++ b/test/expect-tests/vcs/vcs_tests.ml @@ -126,8 +126,7 @@ let run kind script = let config = { Scheduler.Config.concurrency = 1 ; stats = None - ; insignificant_changes = `React - ; signal_watcher = `No + ; print_ctrl_c_warning = false ; watch_exclusions = [] } in