From bd0448fa8a97ec3d098b79088ad77fef263d45a1 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Fri, 6 Dec 2024 14:47:48 +0100 Subject: [PATCH] Upgrade to OCamlformat 0.27.0 Signed-off-by: Jules Aguillon --- .ocamlformat | 2 +- bench/bench.ml | 44 +-- bench/gen_synthetic.ml | 4 +- bench/gen_synthetic_dune_watch.ml | 20 +- bench/metrics.mli | 22 +- bench/micro/path_bench.ml | 67 ++-- bin/build_cmd.ml | 63 +-- bin/describe/aliases_targets.ml | 7 +- bin/describe/describe_workspace.ml | 28 +- bin/dune_init.ml | 8 +- bin/exec.ml | 29 +- bin/import.ml | 6 +- bin/install_uninstall.ml | 84 ++-- bin/monitor.ml | 4 +- bin/ocaml/ocaml_merlin.ml | 4 +- bin/ocaml/top.ml | 78 ++-- bin/pkg/lock.ml | 44 +-- bin/pkg/pkg_common.ml | 6 +- bin/print_rules.ml | 10 +- bin/target.ml | 12 +- bin/workspace_root.mli | 2 +- boot/bootstrap.ml | 9 +- boot/duneboot.ml | 80 ++-- boot/libs.ml | 53 ++- otherlibs/chrome-trace/src/chrome_trace.ml | 6 +- otherlibs/configurator/src/v1.ml | 7 +- otherlibs/dune-rpc-lwt/src/dune_rpc_lwt.ml | 10 +- .../dune-rpc-lwt/test/dune_rpc_lwt_tests.ml | 24 +- otherlibs/dune-rpc/private/conv.ml | 113 +++--- .../dune-rpc/private/dune_rpc_private.ml | 50 +-- otherlibs/dune-rpc/private/types.ml | 40 +- otherlibs/dune-rpc/private/versioned.ml | 171 ++++----- otherlibs/dune-site/src/plugins/plugins.ml | 10 +- otherlibs/ocamlc-loc/test/ocamlc_loc_tests.ml | 10 +- .../dune_filesystem_stubs.ml | 50 +-- otherlibs/stdune/src/fpath.ml | 3 +- otherlibs/stdune/src/lexbuf.ml | 4 +- otherlibs/stdune/src/map.ml | 4 +- otherlibs/stdune/src/sys.ml | 15 +- .../stdune/test/appendable_list_tests.ml | 12 +- otherlibs/stdune/test/bytes_unit_tests.ml | 3 +- otherlibs/stdune/test/filename_tests.ml | 18 +- otherlibs/stdune/test/io_tests.ml | 3 +- otherlibs/stdune/test/loc_tests.ml | 7 +- otherlibs/stdune/test/map_tests.ml | 3 +- otherlibs/stdune/test/path_tests.ml | 219 +++++++---- otherlibs/stdune/test/string_tests.ml | 60 ++- otherlibs/stdune/test/temp_tests.ml | 3 +- src/0install-solver/diagnostics.ml | 20 +- src/0install-solver/sat.ml | 21 +- src/0install-solver/sat.mli | 2 +- src/0install-solver/solver_core.ml | 8 +- src/async_inotify_for_dune/async_inotify.ml | 13 +- src/dune_cache/local.ml | 12 +- src/dune_cache/shared.ml | 18 +- src/dune_config_file/dune_config_file.ml | 24 +- src/dune_digest/digest.ml | 4 +- src/dune_engine/action.ml | 23 +- src/dune_engine/action_exec.ml | 4 +- src/dune_engine/action_exec.mli | 2 +- src/dune_engine/build_config.ml | 30 +- src/dune_engine/build_config_intf.ml | 4 +- src/dune_engine/build_system.ml | 111 +++--- src/dune_engine/context_name.ml | 11 +- src/dune_engine/execution_parameters.ml | 50 +-- src/dune_engine/fs_memo.ml | 18 +- src/dune_engine/load_rules.ml | 38 +- src/dune_engine/process.ml | 189 ++++----- src/dune_engine/process.mli | 2 +- src/dune_engine/reflection.ml | 42 +- src/dune_engine/rule.mli | 2 +- src/dune_engine/rule_cache.ml | 12 +- src/dune_engine/scheduler.ml | 46 +-- src/dune_engine/target_promotion.ml | 14 +- src/dune_file_watcher/dune_file_watcher.ml | 24 +- src/dune_file_watcher/dune_file_watcher.mli | 4 +- src/dune_findlib/config.ml | 6 +- src/dune_lang/action.ml | 6 +- src/dune_lang/bindings.ml | 10 +- src/dune_lang/package.ml | 102 ++--- src/dune_lang/package_info.ml | 2 +- src/dune_lang/slang.ml | 4 +- src/dune_lang/string_with_vars.ml | 24 +- src/dune_lang/string_with_vars.mli | 7 +- src/dune_lang/visibility.ml | 15 +- src/dune_lang/warning.ml | 2 +- src/dune_pkg/dependency_formula.ml | 9 +- src/dune_pkg/fetch.ml | 28 +- src/dune_pkg/fiber_cache.ml | 2 +- src/dune_pkg/local_package.ml | 10 +- src/dune_pkg/lock_dir.ml | 67 ++-- src/dune_pkg/lock_dir.mli | 4 +- src/dune_pkg/mount.ml | 11 +- src/dune_pkg/opam_dyn.ml | 4 +- src/dune_pkg/opam_file.ml | 4 +- src/dune_pkg/opam_repo.ml | 4 +- src/dune_pkg/opam_solver.ml | 66 ++-- src/dune_pkg/package_universe.ml | 11 +- src/dune_pkg/pin_stanza.ml | 7 +- src/dune_pkg/resolve_opam_formula.ml | 21 +- src/dune_pkg/rev_store.ml | 82 ++-- src/dune_pkg/source.ml | 17 +- src/dune_pkg_outdated/dune_pkg_outdated.ml | 14 +- src/dune_rpc_impl/server.ml | 56 +-- src/dune_rpc_server/dune_rpc_server.ml | 20 +- src/dune_rules/action_unexpanded.ml | 14 +- src/dune_rules/artifact_substitution.ml | 31 +- src/dune_rules/buildable_rules.ml | 22 +- src/dune_rules/cinaps.ml | 9 +- src/dune_rules/compilation_context.ml | 41 +- src/dune_rules/context.ml | 130 +++---- src/dune_rules/coq/coq_lib.ml | 44 +-- src/dune_rules/coq/coq_rules.ml | 110 +++--- src/dune_rules/coq/coq_scope.ml | 8 +- src/dune_rules/coq/coq_sources.ml | 2 +- src/dune_rules/cram/cram_exec.ml | 24 +- src/dune_rules/cram/cram_rules.ml | 8 +- src/dune_rules/ctypes/ctypes_field.ml | 4 +- src/dune_rules/ctypes/ctypes_rules.ml | 34 +- src/dune_rules/dep_conf_eval.ml | 4 +- src/dune_rules/dep_rules.ml | 10 +- src/dune_rules/dir_contents.ml | 168 ++++---- src/dune_rules/dir_status.ml | 40 +- src/dune_rules/dune_env.ml | 34 +- src/dune_rules/dune_file.ml | 30 +- src/dune_rules/dune_file0.ml | 30 +- src/dune_rules/dune_project.ml | 101 ++--- src/dune_rules/env_binaries.ml | 6 +- src/dune_rules/env_node.ml | 14 +- src/dune_rules/env_stanza_db.ml | 29 +- src/dune_rules/exe.ml | 96 ++--- src/dune_rules/exe_rules.ml | 49 +-- src/dune_rules/expander.ml | 86 ++--- src/dune_rules/fdo.ml | 9 +- src/dune_rules/file_binding.ml | 10 +- src/dune_rules/findlib.ml | 5 +- src/dune_rules/foreign_rules.ml | 33 +- src/dune_rules/foreign_sources.ml | 13 +- src/dune_rules/format_rules.ml | 12 +- src/dune_rules/gen_meta.ml | 9 +- src/dune_rules/gen_rules.ml | 19 +- src/dune_rules/glob_files_expand.ml | 6 +- src/dune_rules/import.ml | 6 +- src/dune_rules/include_stanza.ml | 6 +- src/dune_rules/inline_tests.ml | 9 +- src/dune_rules/install_entry.ml | 8 +- src/dune_rules/install_rules.ml | 60 +-- src/dune_rules/jsoo/jsoo_rules.ml | 96 ++--- src/dune_rules/lib.ml | 44 +-- src/dune_rules/lib_flags.ml | 64 ++-- src/dune_rules/lib_info.ml | 184 ++++----- src/dune_rules/lib_rules.ml | 73 ++-- src/dune_rules/main.ml | 10 +- src/dune_rules/melange/melange_rules.ml | 68 ++-- src/dune_rules/menhir/menhir_rules.ml | 19 +- src/dune_rules/merlin/merlin.ml | 128 +++---- src/dune_rules/ml_sources.ml | 36 +- src/dune_rules/module.ml | 2 +- src/dune_rules/module_compilation.ml | 26 +- src/dune_rules/modules_field_evaluator.ml | 79 ++-- src/dune_rules/obj_dir.ml | 69 ++-- src/dune_rules/ocaml_stdlib.mli | 6 +- src/dune_rules/ocamldep.ml | 14 +- src/dune_rules/odoc.ml | 44 +-- src/dune_rules/odoc_new.ml | 50 +-- src/dune_rules/only_packages.mli | 2 +- src/dune_rules/opam_create.ml | 5 +- src/dune_rules/packages.ml | 46 +-- src/dune_rules/pkg_rules.ml | 108 +++--- src/dune_rules/pp_spec_rules.ml | 36 +- src/dune_rules/ppx_driver.ml | 17 +- src/dune_rules/scope.ml | 16 +- src/dune_rules/simple_rules.ml | 15 +- .../sites/generate_sites_module_stanza.mli | 6 +- src/dune_rules/slang_expand.ml | 2 +- src/dune_rules/source_tree.ml | 23 +- src/dune_rules/stanzas/buildable.ml | 7 +- .../stanzas/deprecated_library_name.ml | 5 +- src/dune_rules/stanzas/library.ml | 19 +- src/dune_rules/stanzas/library.mli | 2 +- src/dune_rules/super_context.ml | 24 +- src/dune_rules/virtual_rules.ml | 4 +- src/dune_rules/workspace.ml | 105 ++--- src/dune_rules/workspace.mli | 4 +- src/dune_sexp/cst.ml | 10 +- src/dune_sexp/decoder.ml | 10 +- src/dune_sexp/syntax.ml | 6 +- src/dune_sexp/template.ml | 9 +- src/dune_targets/dune_targets.ml | 22 +- src/dune_tui/dune_tui.ml | 9 +- src/dune_tui/widgets/button.ml | 4 +- src/dune_util/gc.ml | 38 +- src/fsevents/fsevents.ml | 48 +-- src/install/paths.ml | 30 +- src/memo/memo.ml | 89 +++-- src/ocaml-config/ocaml_config.ml | 214 +++++------ src/opam-0install/lib/model.ml | 7 +- src/promote/diff_action.ml | 52 +-- src/promote/print_diff.ml | 16 +- src/scheme/scheme.ml | 5 +- .../expect-tests/csexp_rpc/csexp_rpc_tests.ml | 50 +-- .../expect-tests/csexp_rpc/io_buffer_tests.ml | 24 +- test/expect-tests/dag/dag_tests.ml | 6 +- .../dune_action_plugin/dune_action_test.ml | 9 +- .../dune_async_io/async_io_tests.ml | 14 +- .../dune_console/dune_console_tests.ml | 15 +- .../dune_engine/action_to_sh_tests.ml | 55 ++- test/expect-tests/dune_file_tests.ml | 24 +- .../dune_file_watcher_tests_linux.ml | 8 +- .../dune_file_watcher_tests_macos.ml | 8 +- test/expect-tests/dune_lang/sexp_tests.ml | 96 +++-- .../dune_patch/dune_patch_tests.ml | 15 +- test/expect-tests/dune_pkg/fetch_tests.ml | 11 +- test/expect-tests/dune_pkg/git_config.ml | 9 +- test/expect-tests/dune_pkg/rev_store_tests.ml | 3 +- .../dune_pkg_outdated_test.ml | 36 +- test/expect-tests/dune_rpc/dune_rpc_tests.ml | 40 +- .../dune_rpc_e2e/dune_rpc_diagnostics.ml | 24 +- test/expect-tests/dune_util/flock_tests.ml | 6 +- .../fiber_event_bus/fiber_event_bus_tests.ml | 9 +- test/expect-tests/findlib_tests.ml | 7 +- test/expect-tests/fsevents/fsevents_tests.ml | 50 +-- .../memo/graph_dump/dump_graph_tests.ml | 18 +- test/expect-tests/memo/main.ml | 359 +++++++++--------- .../memo/run_with_error_handler.ml | 9 +- test/expect-tests/scheduler_tests.ml | 72 ++-- test/expect-tests/scheme/scheme_tests.ml | 6 +- test/expect-tests/timer_tests.ml | 44 ++- .../artifact_substitution.ml | 4 +- 229 files changed, 3834 insertions(+), 3501 deletions(-) mode change 100755 => 100644 test/expect-tests/dune_file_watcher/dune_file_watcher_tests_linux.ml diff --git a/.ocamlformat b/.ocamlformat index 27ab73c3a02..20afd9fb48c 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,3 +1,3 @@ -version=0.26.2 +version=0.27.0 profile=janestreet ocaml-version=4.08.0 diff --git a/bench/bench.ml b/bench/bench.ml index 6b98ce10c1c..7a27251d182 100644 --- a/bench/bench.ml +++ b/bench/bench.ml @@ -180,28 +180,28 @@ let tag_results { size; clean; zero } = - stack_size - not very useful - forced_collections - only available in OCaml >= 4.12 *) let display_clean_and_zero_with_sandboxing - ({ elapsed_time - ; user_cpu_time - ; system_cpu_time - ; minor_words - ; promoted_words - ; major_words - ; minor_collections - ; major_collections - ; heap_words - ; heap_chunks - ; live_words - ; live_blocks - ; free_words - ; free_blocks - ; largest_free - ; fragments = _ - ; compactions - ; top_heap_words - ; stack_size = _ - } : - _ Metrics.t) - (zero : _ Metrics.t) + ({ elapsed_time + ; user_cpu_time + ; system_cpu_time + ; minor_words + ; promoted_words + ; major_words + ; minor_collections + ; major_collections + ; heap_words + ; heap_chunks + ; live_words + ; live_blocks + ; free_words + ; free_blocks + ; largest_free + ; fragments = _ + ; compactions + ; top_heap_words + ; stack_size = _ + } : + _ Metrics.t) + (zero : _ Metrics.t) = let display what units clean zero = { Output.name = what diff --git a/bench/gen_synthetic.ml b/bench/gen_synthetic.ml index ea0b20c1605..15968625533 100644 --- a/bench/gen_synthetic.ml +++ b/bench/gen_synthetic.ml @@ -8,10 +8,12 @@ let write_modules basedir num_modules = done ;; -let dune = {| +let dune = + {| (library (name test)) |} +;; let write basedir = let () = Unix.mkdir basedir 0o777 in diff --git a/bench/gen_synthetic_dune_watch.ml b/bench/gen_synthetic_dune_watch.ml index d82644c4ae3..b0d0459a1bb 100644 --- a/bench/gen_synthetic_dune_watch.ml +++ b/bench/gen_synthetic_dune_watch.ml @@ -21,10 +21,10 @@ let write_subset base_dir library_index subset = List.flatten (List.map (fun k -> - List.map - (fun j -> - sprintf "M_%d_%d_%d_%d.f()" (library_index - 1) j mod_rows k) - (count subsets_per_library)) + List.map + (fun j -> + sprintf "M_%d_%d_%d_%d.f()" (library_index - 1) j mod_rows k) + (count subsets_per_library)) (count mod_cols)) else List.map @@ -68,17 +68,21 @@ let write_lib ~base_dir ~lib ~dune = let write base_dir = let () = Unix.mkdir base_dir 0o777 in - let dune = {| + let dune = + {| (library (name leaf) (libraries internal)) -|} in +|} + in write_lib ~base_dir ~lib:Leaf ~dune; - let dune = {| + let dune = + {| (library (name internal) (wrapped false)) -|} in +|} + in write_lib ~base_dir ~lib:Internal ~dune ;; diff --git a/bench/metrics.mli b/bench/metrics.mli index 272bfde356a..336819fd4cf 100644 --- a/bench/metrics.mli +++ b/bench/metrics.mli @@ -6,41 +6,41 @@ open Stdune [unzip] functions which make serialisation easier. *) type ('float, 'int) t = { elapsed_time : 'float - (** Real time elapsed since the process started and the process + (** Real time elapsed since the process started and the process finished. *) ; user_cpu_time : 'float - (** The amount of CPU time spent in user mode during the process. Other + (** The amount of CPU time spent in user mode during the process. Other processes and blocked time are not included. *) ; system_cpu_time : 'float - (** The amount of CPU time spent in kernel mode during the process. + (** The amount of CPU time spent in kernel mode during the process. Similar to user time, other processes and time spent blocked by other processes are not counted. *) ; minor_words : 'float - (** Number of words allocated in the minor heap since the program was + (** Number of words allocated in the minor heap since the program was started. *) ; promoted_words : 'float - (** Number of words that have been promoted from the minor to the major + (** Number of words that have been promoted from the minor to the major heap since the program was started. *) ; major_words : 'float - (** Number of words allocated in the major heap since the program was + (** Number of words allocated in the major heap since the program was started. *) ; minor_collections : 'int - (** Number of minor collections since the program was started. *) + (** Number of minor collections since the program was started. *) ; major_collections : 'int - (** Number of major collection cycles completed since the program was + (** Number of major collection cycles completed since the program was started. *) ; heap_words : 'int (** Total size of the major heap, in words. *) ; heap_chunks : 'int - (** Number of contiguous pieces of memory that make up the major heap. *) + (** Number of contiguous pieces of memory that make up the major heap. *) ; live_words : 'int - (** Number of words of live data in the major heap, including the header + (** Number of words of live data in the major heap, including the header words. *) ; live_blocks : 'int (** Number of live blocks in the major heap. *) ; free_words : 'int (** Number of words in the free list. *) ; free_blocks : 'int (** Number of blocks in the free list. *) ; largest_free : 'int (** Size (in words) of the largest block in the free list. *) ; fragments : 'int - (** Number of wasted words due to fragmentation. These are 1-words free + (** Number of wasted words due to fragmentation. These are 1-words free blocks placed between two live blocks. They are not available for allocation. *) ; compactions : 'int (** Number of heap compactions since the program was started. *) diff --git a/bench/micro/path_bench.ml b/bench/micro/path_bench.ml index afb2a7662d4..997b6d770e4 100644 --- a/bench/micro/path_bench.ml +++ b/bench/micro/path_bench.ml @@ -8,29 +8,26 @@ let root = "." let short_path = "a/b/c" let long_path = List.init 20 ~f:(fun _ -> "foo-bar-baz") |> String.concat ~sep:"/" -let%bench_fun ("is_root" [@params - path - = [ "root", "." - ; "short path", short_path - ; "long path", long_path - ]]) +let%bench_fun + ("is_root" + [@params path = [ "root", "."; "short path", short_path; "long path", long_path ]]) = fun () -> ignore (Fpath.is_root path) ;; -let%bench_fun ("reach" [@params - t - = [ "from root long path", (long_path, root) - ; "from root short path", (short_path, root) - ; "reach root from short path", (root, short_path) - ; "reach root from long path", (root, long_path) - ; ( "reach long path from similar long path" - , ( Filename.concat long_path "a" - , Filename.concat long_path "b" ) ) - ; ( "reach short path from similar short path" - , ( Filename.concat short_path "a" - , Filename.concat short_path "b" ) ) - ]]) +let%bench_fun + ("reach" + [@params + t + = [ "from root long path", (long_path, root) + ; "from root short path", (short_path, root) + ; "reach root from short path", (root, short_path) + ; "reach root from long path", (root, long_path) + ; ( "reach long path from similar long path" + , (Filename.concat long_path "a", Filename.concat long_path "b") ) + ; ( "reach short path from similar short path" + , (Filename.concat short_path "a", Filename.concat short_path "b") ) + ]]) = let t, from = t in let t = Path.of_string t in @@ -38,26 +35,30 @@ let%bench_fun ("reach" [@params fun () -> ignore (Path.reach t ~from) ;; -let%bench_fun ("Path.Local.relative" [@params - t - = [ "left root", (".", long_path) - ; "right root", (long_path, ".") - ; "short paths", (short_path, short_path) - ; "long paths", (long_path, long_path) - ]]) +let%bench_fun + ("Path.Local.relative" + [@params + t + = [ "left root", (".", long_path) + ; "right root", (long_path, ".") + ; "short paths", (short_path, short_path) + ; "long paths", (long_path, long_path) + ]]) = let x, y = t in let x = Path.Local.of_string x in fun () -> ignore (Path.Local.relative x y) ;; -let%bench_fun ("Path.Local.append" [@params - t - = [ "left root", (".", long_path) - ; "right root", (long_path, ".") - ; "short paths", (short_path, short_path) - ; "long paths", (long_path, long_path) - ]]) +let%bench_fun + ("Path.Local.append" + [@params + t + = [ "left root", (".", long_path) + ; "right root", (long_path, ".") + ; "short paths", (short_path, short_path) + ; "long paths", (long_path, long_path) + ]]) = let x, y = t in let x = Path.Local.of_string x in diff --git a/bin/build_cmd.ml b/bin/build_cmd.ml index 19fa78f0b20..4b3f01b5934 100644 --- a/bin/build_cmd.ml +++ b/bin/build_cmd.ml @@ -37,46 +37,47 @@ let run_build_system ~common ~request = let open Fiber.O in Fiber.finalize (fun () -> - (* CR-someday amokhov: Currently we invalidate cached timestamps on every + (* CR-someday amokhov: Currently we invalidate cached timestamps on every incremental rebuild. This conservative approach helps us to work around some [mtime] resolution problems (e.g. on Mac OS). It would be nice to find a way to avoid doing this. In fact, this may be unnecessary even for the initial build if we assume that the user does not modify files in the [_build] directory. For now, it's unclear if optimising this is worth the effort. *) - Cached_digest.invalidate_cached_timestamps (); - let* setup = Import.Main.setup () in - let request = - Action_builder.bind (Action_builder.of_memo setup) ~f:(fun setup -> request setup) - in - (* CR-someday cmoseley: Can we avoid creating a new lazy memo node every + Cached_digest.invalidate_cached_timestamps (); + let* setup = Import.Main.setup () in + let request = + Action_builder.bind (Action_builder.of_memo setup) ~f:(fun setup -> + request setup) + in + (* CR-someday cmoseley: Can we avoid creating a new lazy memo node every time the build system is rerun? *) - (* This top-level node is used for traversing the whole Memo graph. *) - let toplevel_cell, toplevel = - Memo.Lazy.Expert.create ~name:"toplevel" (fun () -> - let open Memo.O in - let+ (), (_ : Dep.Fact.t Dep.Map.t) = - Action_builder.evaluate_and_collect_facts request - in - ()) - in - let* res = run ~toplevel in - let+ () = - match Common.dump_memo_graph_file common with - | None -> Fiber.return () - | Some file -> - let path = Path.external_ file in - let+ graph = - Memo.dump_cached_graph - ~time_nodes:(Common.dump_memo_graph_with_timing common) - toplevel_cell - in - Graph.serialize graph ~path ~format:(Common.dump_memo_graph_format common) - (* CR-someday cmoseley: It would be nice to use Persistent to dump a + (* This top-level node is used for traversing the whole Memo graph. *) + let toplevel_cell, toplevel = + Memo.Lazy.Expert.create ~name:"toplevel" (fun () -> + let open Memo.O in + let+ (), (_ : Dep.Fact.t Dep.Map.t) = + Action_builder.evaluate_and_collect_facts request + in + ()) + in + let* res = run ~toplevel in + let+ () = + match Common.dump_memo_graph_file common with + | None -> Fiber.return () + | Some file -> + let path = Path.external_ file in + let+ graph = + Memo.dump_cached_graph + ~time_nodes:(Common.dump_memo_graph_with_timing common) + toplevel_cell + in + Graph.serialize graph ~path ~format:(Common.dump_memo_graph_format common) + (* CR-someday cmoseley: It would be nice to use Persistent to dump a copy of the graph's internal representation here, so it could be used without needing to re-run the build*) - in - res) + in + res) ~finally:(fun () -> Hooks.End_of_build.run (); Fiber.return ()) diff --git a/bin/describe/aliases_targets.ml b/bin/describe/aliases_targets.ml index 8286bbf06b9..3f1aeafbe0a 100644 --- a/bin/describe/aliases_targets.ml +++ b/bin/describe/aliases_targets.ml @@ -24,9 +24,10 @@ let ls_term (fetch_results : Path.Build.t -> string list Action_builder.t) = (* We only drop the build context if it is correct. *) match Path.Build.extract_build_context d with | Some (dir_context_name, d) -> - if Dune_engine.Context_name.equal - context - (Dune_engine.Context_name.of_string dir_context_name) + if + Dune_engine.Context_name.equal + context + (Dune_engine.Context_name.of_string dir_context_name) then d else User_error.raise diff --git a/bin/describe/describe_workspace.ml b/bin/describe/describe_workspace.ml index b2cf2faa72f..acc06229cf0 100644 --- a/bin/describe/describe_workspace.ml +++ b/bin/describe/describe_workspace.ml @@ -5,7 +5,7 @@ module Options = struct type t = { with_deps : bool (* whether to compute direct dependencies between modules *) ; with_pps : bool - (* whether to include the dependencies to ppx-rewriters (that are + (* whether to include the dependencies to ppx-rewriters (that are used at compile time) *) } @@ -72,9 +72,9 @@ module Descr = struct module Mod_deps = struct type t = { for_intf : Dune_rules.Module_name.t list - (* direct module dependencies for the interface *) + (* direct module dependencies for the interface *) ; for_impl : Dune_rules.Module_name.t list - (* direct module dependencies for the implementation *) + (* direct module dependencies for the implementation *) } (* Conversion to the [Dyn.t] type *) @@ -129,7 +129,7 @@ module Descr = struct type t = { names : string list (* names of the executable *) ; requires : Digest.t list - (* list of direct dependencies to libraries, identified by their + (* list of direct dependencies to libraries, identified by their digests *) ; modules : Mod.t list (* list of the modules the executable is composed of *) ; include_dirs : Path.t list (* list of include directories *) @@ -157,10 +157,10 @@ module Descr = struct ; uid : Digest.t (* digest of the library *) ; local : bool (* whether this library is local *) ; requires : Digest.t list - (* list of direct dependendies to libraries, identified by their + (* list of direct dependendies to libraries, identified by their digests *) ; source_dir : Path.t - (* path to the directory that contains the sources of this library *) + (* path to the directory that contains the sources of this library *) ; modules : Mod.t list (* list of the modules the executable is composed of *) ; include_dirs : Path.t list (* list of include directories *) } @@ -348,10 +348,10 @@ module Crawl = struct (* Builds the description of a module from a module and its object directory *) let module_ - ~obj_dir - ~(deps_for_intf : Module.t list) - ~(deps_for_impl : Module.t list) - (m : Module.t) + ~obj_dir + ~(deps_for_intf : Module.t list) + ~(deps_for_impl : Module.t list) + (m : Module.t) : Descr.Mod.t = let source ml_kind = Option.map (Module.source m ~ml_kind) ~f:Module.File.path in @@ -542,10 +542,10 @@ module Crawl = struct (* Builds a workspace description for the provided dune setup and context *) let workspace - options - ({ Dune_rules.Main.contexts = _; scontexts } : Dune_rules.Main.build_system) - (context : Context.t) - dirs + options + ({ Dune_rules.Main.contexts = _; scontexts } : Dune_rules.Main.build_system) + (context : Context.t) + dirs : Descr.Workspace.t Memo.t = let context_name = Context.name context in diff --git a/bin/dune_init.ml b/bin/dune_init.ml index db72fdf9b52..da3c8e40a7d 100644 --- a/bin/dune_init.ml +++ b/bin/dune_init.ml @@ -377,10 +377,10 @@ module Component = struct (* A list of CSTs for dune-project file content *) let dune_project - ~opam_file_gen - ~(defaults : Dune_config_file.Dune_config.Project_defaults.t) - dir - (common : Options.Common.t) + ~opam_file_gen + ~(defaults : Dune_config_file.Dune_config.Project_defaults.t) + dir + (common : Options.Common.t) = let cst = let package = diff --git a/bin/exec.ml b/bin/exec.ml index dec09ddf16a..71628cccb22 100644 --- a/bin/exec.ml +++ b/bin/exec.ml @@ -4,7 +4,8 @@ let doc = "Execute a command in a similar environment as if installation was per let man = [ `S "DESCRIPTION" - ; `P {|$(b,dune exec -- COMMAND) should behave in the same way as if you + ; `P + {|$(b,dune exec -- COMMAND) should behave in the same way as if you do:|} ; `Pre " \\$ dune install\n \\$ COMMAND" ; `P @@ -95,9 +96,9 @@ module Command_to_exec = struct (* Run the command, first (re)building the program which the command is invoking *) let build_and_run_in_child_process - ~root - ~config - { get_env_and_build_if_necessary; prog; args } + ~root + ~config + { get_env_and_build_if_necessary; prog; args } = get_env_and_build_if_necessary prog |> Fiber.map @@ -225,16 +226,16 @@ let get_path_and_build_if_necessary sctx ~no_rebuild ~dir ~prog = let path = Path.relative_to_source_in_build_or_external ~dir prog in Build_system.file_exists path >>= (function - | true -> Memo.return (Some path) - | false -> - if not (Filename.check_suffix prog ".exe") - then Memo.return None - else ( - let path = Path.extend_basename path ~suffix:".exe" in - Build_system.file_exists path - >>| function - | true -> Some path - | false -> None)) + | true -> Memo.return (Some path) + | false -> + if not (Filename.check_suffix prog ".exe") + then Memo.return None + else ( + let path = Path.extend_basename path ~suffix:".exe" in + Build_system.file_exists path + >>| function + | true -> Some path + | false -> None)) >>= (function | Some path -> build_prog ~no_rebuild ~prog path | None -> not_found ~dir ~prog) diff --git a/bin/import.ml b/bin/import.ml index 100a9e112da..91dd70203b5 100644 --- a/bin/import.ml +++ b/bin/import.ml @@ -206,9 +206,9 @@ module Scheduler = struct ;; let go_with_rpc_server_and_console_status_reporting - ~(common : Common.t) - ~config:dune_config - run + ~(common : Common.t) + ~config:dune_config + run = let server = match Common.rpc common with diff --git a/bin/install_uninstall.ml b/bin/install_uninstall.ml index 1db2a69c6f4..b7434cc1e6b 100644 --- a/bin/install_uninstall.ml +++ b/bin/install_uninstall.ml @@ -19,9 +19,9 @@ let synopsis = let print_line ~(verbosity : Dune_engine.Display.t) fmt = Printf.ksprintf (fun s -> - match verbosity with - | Quiet -> () - | _ -> Console.print [ Pp.verbatim s ]) + match verbosity with + | Quiet -> () + | _ -> Console.print [ Pp.verbatim s ]) fmt ;; @@ -293,12 +293,12 @@ module File_ops_real (W : sig ;; let copy_file - ~src - ~dst - ~executable - ~kind - ~package - ~(conf : Artifact_substitution.Conf.t) + ~src + ~dst + ~executable + ~kind + ~package + ~(conf : Artifact_substitution.Conf.t) = let chmod = if executable then fun _ -> 0o755 else fun _ -> 0o644 in let plain_copy () = Io.copy_file ~chmod ~src ~dst () in @@ -313,14 +313,14 @@ module File_ops_real (W : sig Io.close_both (ic, oc); Fiber.return ()) (fun () -> - let f = - match sf with - | META -> process_meta - | Dune_package -> - process_dune_package - ~get_location:(Artifact_substitution.Conf.get_location conf) - in - copy_special_file ~src ~package ~ic ~oc ~f) + let f = + match sf with + | META -> process_meta + | Dune_package -> + process_dune_package + ~get_location:(Artifact_substitution.Conf.get_location conf) + in + copy_special_file ~src ~package ~ic ~oc ~f) in (match status with | Done -> () @@ -403,13 +403,13 @@ let file_operations ~verbosity ~dry_run ~workspace : (module File_operations) = if dry_run then (module File_ops_dry_run (struct - let verbosity = verbosity - end)) + let verbosity = verbosity + end)) else (module File_ops_real (struct - let workspace = workspace - let verbosity = verbosity - end)) + let workspace = workspace + let verbosity = verbosity + end)) ;; let package_is_vendored (pkg : Package.t) = @@ -432,14 +432,14 @@ let cmd_what = function ;; let install_entry - ~ops - ~conf - ~package - ~dir - ~create_install_files - (entry : Path.t Install.Entry.t) - ~dst - ~verbosity + ~ops + ~conf + ~package + ~dir + ~create_install_files + (entry : Path.t Install.Entry.t) + ~dst + ~verbosity = let module Ops = (val ops : File_operations) in let open Fiber.O in @@ -482,18 +482,18 @@ let install_entry ;; let run - what - context - common - pkgs - sections - (config : Dune_config.t) - ~dry_run - ~destdir - ~relocatable - ~create_install_files - ~prefix_from_command_line - ~(from_command_line : _ Install.Roots.t) + what + context + common + pkgs + sections + (config : Dune_config.t) + ~dry_run + ~destdir + ~relocatable + ~create_install_files + ~prefix_from_command_line + ~(from_command_line : _ Install.Roots.t) = let open Fiber.O in let* workspace = Workspace.get () in diff --git a/bin/monitor.ml b/bin/monitor.ml index 6f63f3e1653..f887cfa991b 100644 --- a/bin/monitor.ml +++ b/bin/monitor.ml @@ -188,8 +188,8 @@ let fetch_loop ~(event : Event.t Fiber_event_bus.t) ~client ~f sub = let rec loop () = Fiber.collect_errors (fun () -> Client.Stream.next poller) >>= (function - | Ok (Some payload) -> Fiber_event_bus.push event (f payload) - | Error _ | Ok None -> Fiber_event_bus.close event >>> Fiber.return `Closed) + | Ok (Some payload) -> Fiber_event_bus.push event (f payload) + | Error _ | Ok None -> Fiber_event_bus.close event >>> Fiber.return `Closed) >>= function | `Closed -> Fiber.return () | `Ok -> loop () diff --git a/bin/ocaml/ocaml_merlin.ml b/bin/ocaml/ocaml_merlin.ml index e68a5cd3617..44c35426e47 100644 --- a/bin/ocaml/ocaml_merlin.ml +++ b/bin/ocaml/ocaml_merlin.ml @@ -169,8 +169,8 @@ end = struct 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) + | Error s -> Merlin_conf.make_error s + | Ok file -> load_merlin_file file) >>| Merlin_conf.to_stdout ;; diff --git a/bin/ocaml/top.ml b/bin/ocaml/top.ml index 679f3e4a3ae..2d8acff5986 100644 --- a/bin/ocaml/top.ml +++ b/bin/ocaml/top.ml @@ -138,44 +138,46 @@ module Module = struct Memo.fork_and_join (fun () -> files_to_load_of_requires sctx requires) (fun () -> - let cmis () = - let glob = - Dune_engine.File_selector.of_glob - ~dir:(Path.build (Obj_dir.byte_dir private_obj_dir)) - (Dune_lang.Glob.of_string_exn Loc.none "*.cmi") - in - let* files = Build_system.eval_pred glob in - Memo.parallel_iter (Filename_set.to_list files) ~f:Build_system.build_file - in - let cmos () = - let obj_dir = Compilation_context.obj_dir cctx in - let dep_graph = (Compilation_context.dep_graphs cctx).impl in - let* modules = - let graph = - Dune_rules.Dep_graph.top_closed_implementations dep_graph [ module_ ] - in - let+ modules, _ = Action_builder.evaluate_and_collect_facts graph in - modules - in - let cmos = - let module Module = Dune_rules.Module in - let module Module_name = Dune_rules.Module_name in - let module_obj_name = Module.obj_name module_ in - List.filter_map modules ~f:(fun m -> - let obj_dir = - if Module_name.Unique.equal module_obj_name (Module.obj_name m) - then private_obj_dir - else obj_dir - in - Obj_dir.Module.cm_file obj_dir m ~kind:(Ocaml Cmo) - |> Option.map ~f:Path.build) - in - let+ (_ : Dep.Facts.t) = - Build_system.build_deps (Dep.Set.of_files cmos) - in - cmos - in - Memo.fork_and_join_unit cmis cmos) + let cmis () = + let glob = + Dune_engine.File_selector.of_glob + ~dir:(Path.build (Obj_dir.byte_dir private_obj_dir)) + (Dune_lang.Glob.of_string_exn Loc.none "*.cmi") + in + let* files = Build_system.eval_pred glob in + Memo.parallel_iter + (Filename_set.to_list files) + ~f:Build_system.build_file + in + let cmos () = + let obj_dir = Compilation_context.obj_dir cctx in + let dep_graph = (Compilation_context.dep_graphs cctx).impl in + let* modules = + let graph = + Dune_rules.Dep_graph.top_closed_implementations dep_graph [ module_ ] + in + let+ modules, _ = Action_builder.evaluate_and_collect_facts graph in + modules + in + let cmos = + let module Module = Dune_rules.Module in + let module Module_name = Dune_rules.Module_name in + let module_obj_name = Module.obj_name module_ in + List.filter_map modules ~f:(fun m -> + let obj_dir = + if Module_name.Unique.equal module_obj_name (Module.obj_name m) + then private_obj_dir + else obj_dir + in + Obj_dir.Module.cm_file obj_dir m ~kind:(Ocaml Cmo) + |> Option.map ~f:Path.build) + in + let+ (_ : Dep.Facts.t) = + Build_system.build_deps (Dep.Set.of_files cmos) + in + cmos + in + Memo.fork_and_join_unit cmis cmos) in libs @ modules in diff --git a/bin/pkg/lock.ml b/bin/pkg/lock.ml index b0865cdac53..c9a93cc9fd2 100644 --- a/bin/pkg/lock.ml +++ b/bin/pkg/lock.ml @@ -67,13 +67,13 @@ let resolve_project_sources sources = ;; let solve_lock_dir - workspace - ~local_packages - ~project_sources - version_preference - solver_env_from_current_system - lock_dir_path - progress_state + workspace + ~local_packages + ~project_sources + version_preference + solver_env_from_current_system + lock_dir_path + progress_state = let open Fiber.O in let lock_dir = Workspace.find_lock_dir workspace lock_dir_path in @@ -139,12 +139,12 @@ let solve_lock_dir ;; let solve - workspace - ~local_packages - ~project_sources - ~solver_env_from_current_system - ~version_preference - ~lock_dirs + workspace + ~local_packages + ~project_sources + ~solver_env_from_current_system + ~version_preference + ~lock_dirs = let open Fiber.O in (* a list of thunks that will perform all the file IO side @@ -161,15 +161,15 @@ let solve Console.Status_line.remove_overlay overlay; Fiber.return ()) (fun () -> - Fiber.parallel_map progress_indicator ~f:(fun { lockdir_path; state } -> - solve_lock_dir - workspace - ~local_packages - ~project_sources - version_preference - solver_env_from_current_system - lockdir_path - state)) + Fiber.parallel_map progress_indicator ~f:(fun { lockdir_path; state } -> + solve_lock_dir + workspace + ~local_packages + ~project_sources + version_preference + solver_env_from_current_system + lockdir_path + state)) in List.partition_map result ~f:Result.to_either in diff --git a/bin/pkg/pkg_common.ml b/bin/pkg/pkg_common.ml index a4da1b361ba..99a577c4d84 100644 --- a/bin/pkg/pkg_common.ml +++ b/bin/pkg/pkg_common.ml @@ -5,9 +5,9 @@ module Package_variable_name = Dune_lang.Package_variable_name module Variable_value = Dune_pkg.Variable_value let solver_env - ~solver_env_from_current_system - ~solver_env_from_context - ~unset_solver_vars_from_context + ~solver_env_from_current_system + ~solver_env_from_context + ~unset_solver_vars_from_context = let solver_env = [ solver_env_from_current_system; solver_env_from_context ] diff --git a/bin/print_rules.ml b/bin/print_rules.ml index beef4f5e882..4786e64830e 100644 --- a/bin/print_rules.ml +++ b/bin/print_rules.ml @@ -47,8 +47,8 @@ let print_rule_makefile ppf (rule : Dune_engine.Reflection.Rule.t) = Format.pp_print_string ppf (Path.to_string p))) targets (fun ppf -> - Path.Set.iter rule.expanded_deps ~f:(fun dep -> - Format.fprintf ppf "@ %s" (Path.to_string dep))) + Path.Set.iter rule.expanded_deps ~f:(fun dep -> + Format.fprintf ppf "@ %s" (Path.to_string dep))) Pp.to_fmt (Action_to_sh.pp action) ;; @@ -155,9 +155,9 @@ let print_rule_sexp ppf (rule : Dune_engine.Reflection.Rule.t) = let paths ps = Dune_sexp.Encoder.list (fun p -> - Path.Build.relative rule.targets.root p - |> Path.Build.to_string - |> Dune_sexp.atom_or_quoted_string) + Path.Build.relative rule.targets.root p + |> Path.Build.to_string + |> Dune_sexp.atom_or_quoted_string) (Filename.Set.to_list ps) in let sexp = diff --git a/bin/target.ml b/bin/target.ml index ada1036143b..8a6ecdbf41a 100644 --- a/bin/target.ml +++ b/bin/target.ml @@ -222,10 +222,10 @@ let resolve_target root ~setup target = ;; let resolve_targets - root - (config : Dune_config.t) - (setup : Dune_rules.Main.build_system) - user_targets + root + (config : Dune_config.t) + (setup : Dune_rules.Main.build_system) + user_targets = match user_targets with | [] -> Action_builder.return [] @@ -237,8 +237,8 @@ let resolve_targets [ Pp.text "Actual targets:" ; Pp.enumerate (List.concat_map targets ~f:(function - | Ok targets -> targets - | Error _ -> [])) + | Ok targets -> targets + | Error _ -> [])) ~f:(function | File p -> Pp.verbatim (Path.to_string_maybe_quoted p) | Alias a -> Alias.pp a) diff --git a/bin/workspace_root.mli b/bin/workspace_root.mli index 391dd0f64db..c28c94b751d 100644 --- a/bin/workspace_root.mli +++ b/bin/workspace_root.mli @@ -14,7 +14,7 @@ type t = { dir : string ; to_cwd : string list (** How to reach the cwd from the root *) ; reach_from_root_prefix : string - (** Prefix filenames with this to reach them from the root *) + (** Prefix filenames with this to reach them from the root *) ; kind : Kind.t } diff --git a/boot/bootstrap.ml b/boot/bootstrap.ml index eded89df320..312101a137a 100644 --- a/boot/bootstrap.ml +++ b/boot/bootstrap.ml @@ -38,8 +38,9 @@ let () = then at_exit (fun () -> Array.iter (Sys.readdir ".") ~f:(fun fn -> - if String.length fn >= String.length duneboot - && String.sub fn ~pos:0 ~len:(String.length duneboot) = duneboot + if + String.length fn >= String.length duneboot + && String.sub fn ~pos:0 ~len:(String.length duneboot) = duneboot then ( try Sys.remove fn with | Sys_error _ -> ()))) @@ -48,8 +49,8 @@ let () = let runf fmt = ksprintf (fun cmd -> - prerr_endline cmd; - Sys.command cmd) + prerr_endline cmd; + Sys.command cmd) fmt ;; diff --git a/boot/duneboot.ml b/boot/duneboot.ml index 5cbb898f311..b4059b07ca2 100644 --- a/boot/duneboot.ml +++ b/boot/duneboot.ml @@ -67,8 +67,8 @@ let ( ^/ ) = Filename.concat let fatal fmt = ksprintf (fun s -> - prerr_endline s; - exit 2) + prerr_endline s; + exit 2) fmt ;; @@ -816,8 +816,8 @@ module Library = struct let oc = open_out (build_dir ^/ fn) in StringSet.iter (fun m -> - if m <> t.toplevel_module - then fprintf oc "module %s = %s__%s\n" m t.toplevel_module m) + if m <> t.toplevel_module + then fprintf oc "module %s = %s__%s\n" m t.toplevel_module m) modules; close_out oc; Some fn @@ -865,29 +865,29 @@ module Library = struct let header = Wrapper.header wrapper in Fiber.fork_and_join (fun () -> - Fiber.parallel_map files ~f:(fun (fn, kind) -> - let mangled = Wrapper.mangle_filename wrapper fn kind in - let dst = build_dir ^/ mangled in - match kind with - | Header | C -> - copy "line" fn dst; - Fiber.return [ mangled ] - | Ml | Mli -> - copy "" fn dst ~header; - Fiber.return [ mangled ] - | Mll -> copy_lexer fn dst ~header >>> Fiber.return [ mangled ] - | Mly -> copy_parser fn dst ~header >>> Fiber.return [ mangled; mangled ^ "i" ])) + Fiber.parallel_map files ~f:(fun (fn, kind) -> + let mangled = Wrapper.mangle_filename wrapper fn kind in + let dst = build_dir ^/ mangled in + match kind with + | Header | C -> + copy "line" fn dst; + Fiber.return [ mangled ] + | Ml | Mli -> + copy "" fn dst ~header; + Fiber.return [ mangled ] + | Mll -> copy_lexer fn dst ~header >>> Fiber.return [ mangled ] + | Mly -> copy_parser fn dst ~header >>> Fiber.return [ mangled; mangled ^ "i" ])) (fun () -> - match build_info_module with - | None -> Fiber.return None - | Some m -> - let fn = String.uncapitalize_ascii m ^ ".ml" in - let mangled = Wrapper.mangle_filename wrapper fn Ml in - let oc = open_out (build_dir ^/ mangled) in - Build_info.gen_data_module oc - >>| fun () -> - close_out oc; - Some mangled) + match build_info_module with + | None -> Fiber.return None + | Some m -> + let fn = String.uncapitalize_ascii m ^ ".ml" in + let mangled = Wrapper.mangle_filename wrapper fn Ml in + let oc = open_out (build_dir ^/ mangled) in + Build_info.gen_data_module oc + >>| fun () -> + close_out oc; + Some mangled) >>| fun (files, build_info_file) -> let files = List.concat files in let files = @@ -982,7 +982,9 @@ let get_dependencies libraries = let deps = List.rev_append ((* Alias files have no dependencies *) - List.rev_map alias_files ~f:(fun fn -> fn, [])) + List.rev_map + alias_files + ~f:(fun fn -> fn, [])) (List.rev_map dependencies ~f:(convert_dependencies ~all_source_files)) in if debug @@ -1060,12 +1062,12 @@ let common_build_args name ~external_includes ~external_libraries = let allow_unstable_sources = [ "-alert"; "-unstable" ] let build - ~ocaml_config - ~dependencies - ~c_files - ~build_flags - ~link_flags - { target = name, main; external_libraries; _ } + ~ocaml_config + ~dependencies + ~c_files + ~build_flags + ~link_flags + { target = name, main; external_libraries; _ } = let ext_obj = try StringMap.find "ext_obj" ocaml_config with @@ -1107,12 +1109,12 @@ let build Fiber.fork_and_join_unit (fun () -> build (Filename.basename main)) (fun () -> - Fiber.parallel_map c_files ~f:(fun file -> - Process.run - ~cwd:build_dir - Config.compiler - (List.concat [ [ "-c"; "-g" ]; external_includes; build_flags; [ file ] ]) - >>| fun () -> Filename.chop_extension file ^ ext_obj)) + Fiber.parallel_map c_files ~f:(fun file -> + Process.run + ~cwd:build_dir + Config.compiler + (List.concat [ [ "-c"; "-g" ]; external_includes; build_flags; [ file ] ]) + >>| fun () -> Filename.chop_extension file ^ ext_obj)) >>= fun obj_files -> let compiled_ml_ext = match Config.mode with diff --git a/boot/libs.ml b/boot/libs.ml index 6faacb217ec..72835c33109 100644 --- a/boot/libs.ml +++ b/boot/libs.ml @@ -4,10 +4,8 @@ let local_libraries = [ ("otherlibs/ordering", Some "Ordering", false, None) ; ("vendor/pp/src", Some "Pp", false, None) ; ("otherlibs/dyn", Some "Dyn", false, None) - ; ("otherlibs/stdune/dune_filesystem_stubs", - Some "Dune_filesystem_stubs", - false, - None) + ; ("otherlibs/stdune/dune_filesystem_stubs", Some "Dune_filesystem_stubs", + false, None) ; ("vendor/csexp/src", Some "Csexp", false, None) ; ("otherlibs/stdune/src", Some "Stdune", false, None) ; ("src/dune_graph", Some "Dune_graph", false, None) @@ -25,10 +23,8 @@ let local_libraries = ; ("vendor/spawn/src", Some "Spawn", false, None) ; ("src/dune_stats", Some "Dune_stats", false, None) ; ("otherlibs/xdg", Some "Xdg", false, None) - ; ("vendor/build_path_prefix_map/src", - Some "Build_path_prefix_map", - false, - None) + ; ("vendor/build_path_prefix_map/src", Some "Build_path_prefix_map", false, + None) ; ("vendor/uutf", None, false, None) ; ("src/dune_sexp", Some "Dune_sexp", false, None) ; ("src/dune_util", Some "Dune_util", false, None) @@ -39,18 +35,18 @@ let local_libraries = ; ("src/dune_targets", Some "Dune_targets", false, None) ; ("src/dune_cache", Some "Dune_cache", false, None) ; ("otherlibs/dune-rpc/private", Some "Dune_rpc_private", false, None) - ; ("otherlibs/dune-action-plugin/src", - Some "Dune_action_plugin", - false, - None) - ; ("src/dune_output_truncation", Some "Dune_output_truncation", false, None) + ; ("otherlibs/dune-action-plugin/src", Some "Dune_action_plugin", false, + None) + ; ("src/dune_output_truncation", Some "Dune_output_truncation", false, + None) ; ("src/csexp_rpc", Some "Csexp_rpc", false, None) ; ("src/dune_rpc_client", Some "Dune_rpc_client", false, None) ; ("src/dune_thread_pool", Some "Dune_thread_pool", false, None) ; ("otherlibs/ocamlc-loc/src", Some "Ocamlc_loc", false, None) ; ("src/fsevents", Some "Fsevents", false, None) ; ("vendor/ocaml-inotify/src", Some "Ocaml_inotify", false, None) - ; ("src/async_inotify_for_dune", Some "Async_inotify_for_dune", false, None) + ; ("src/async_inotify_for_dune", Some "Async_inotify_for_dune", false, + None) ; ("src/fswatch_win", Some "Fswatch_win", false, None) ; ("src/dune_file_watcher", Some "Dune_file_watcher", false, None) ; ("src/dune_engine", Some "Dune_engine", false, None) @@ -65,10 +61,8 @@ let local_libraries = ; ("otherlibs/dune-private-libs/section", Some "Dune_section", false, None) ; ("src/dune_lang", Some "Dune_lang", false, None) ; ("src/fiber_event_bus", Some "Fiber_event_bus", false, None) - ; ("otherlibs/dune-private-libs/meta_parser", - Some "Dune_meta_parser", - false, - None) + ; ("otherlibs/dune-private-libs/meta_parser", Some "Dune_meta_parser", + false, None) ; ("src/fs", Some "Fs", false, None) ; ("src/dune_findlib", Some "Dune_findlib", false, None) ; ("src/dune_vcs", Some "Dune_vcs", false, None) @@ -76,14 +70,13 @@ let local_libraries = ; ("vendor/opam/src/state", None, false, None) ; ("src/0install-solver", Some "Zeroinstall_solver", false, None) ; ("src/opam-0install/lib", Some "Opam_0install", false, None) - ; ("otherlibs/dune-build-info/src", - Some "Build_info", - false, - Some "Build_info_data") + ; ("otherlibs/dune-build-info/src", Some "Build_info", false, + Some "Build_info_data") ; ("vendor/fmt/src", None, false, None) ; ("src/dune_pkg", Some "Dune_pkg", false, None) ; ("src/install", Some "Install", false, None) - ; ("otherlibs/dune-site/src/private", Some "Dune_site_private", false, None) + ; ("otherlibs/dune-site/src/private", Some "Dune_site_private", false, + None) ; ("src/dune_threaded_console", Some "Dune_threaded_console", false, None) ; ("vendor/lwd/lwd", None, false, None) ; ("vendor/notty/src", None, true, None) @@ -104,17 +97,17 @@ let local_libraries = let build_flags = [ ([ "win32"; "win64"; "mingw"; "mingw64" ], - [ "-ccopt"; "-D_UNICODE"; "-ccopt"; "-DUNICODE" ]) + [ "-ccopt"; "-D_UNICODE"; "-ccopt"; "-DUNICODE" ]) ] let link_flags = [ ([ "macosx" ], - [ "-cclib" - ; "-framework CoreFoundation" - ; "-cclib" - ; "-framework CoreServices" - ]) + [ "-cclib" + ; "-framework CoreFoundation" + ; "-cclib" + ; "-framework CoreServices" + ]) ; ([ "win32"; "win64"; "mingw"; "mingw64" ], - [ "-cclib"; "-lshell32"; "-cclib"; "-lole32"; "-cclib"; "-luuid" ]) + [ "-cclib"; "-lshell32"; "-cclib"; "-lole32"; "-cclib"; "-luuid" ]) ; ([ "beos" ], [ "-cclib"; "-lbsd" ]) ] diff --git a/otherlibs/chrome-trace/src/chrome_trace.ml b/otherlibs/chrome-trace/src/chrome_trace.ml index 128dc496ef9..dc36ea251d4 100644 --- a/otherlibs/chrome-trace/src/chrome_trace.ml +++ b/otherlibs/chrome-trace/src/chrome_trace.ml @@ -196,9 +196,9 @@ module Event = struct let fields = add_field_opt (fun tts -> "tts", Timestamp.to_json tts) tts fields in add_field_opt (fun stackframe -> - match stackframe with - | `Id id -> "sf", Id.to_json id - | `Raw r -> "stack", Stack_frame.Raw.to_json r) + match stackframe with + | `Id id -> "sf", Id.to_json id + | `Raw r -> "stack", Stack_frame.Raw.to_json r) stackframe fields ;; diff --git a/otherlibs/configurator/src/v1.ml b/otherlibs/configurator/src/v1.ml index ddd8446fb14..d9ab15c83f1 100644 --- a/otherlibs/configurator/src/v1.ml +++ b/otherlibs/configurator/src/v1.ml @@ -696,9 +696,10 @@ module Pkg_config = struct match expr with | Some e -> e | None -> - if String.exists package ~f:(function - | '=' | '>' | '<' -> true - | _ -> false) + if + String.exists package ~f:(function + | '=' | '>' | '<' -> true + | _ -> false) then warn "Package name %S contains invalid characters. Use Pkg_config.query_expr to \ diff --git a/otherlibs/dune-rpc-lwt/src/dune_rpc_lwt.ml b/otherlibs/dune-rpc-lwt/src/dune_rpc_lwt.ml index b3b96e83ac5..dc0bdbb1514 100644 --- a/otherlibs/dune-rpc-lwt/src/dune_rpc_lwt.ml +++ b/otherlibs/dune-rpc-lwt/src/dune_rpc_lwt.ml @@ -106,11 +106,11 @@ module V1 = struct Lwt.try_bind (fun () -> Lwt_unix.stat s) (fun stat -> - Lwt.return - (match stat.st_kind with - | Unix.S_SOCK -> Ok `Unix_socket - | S_REG -> Ok `Normal_file - | _ -> Ok `Other)) + Lwt.return + (match stat.st_kind with + | Unix.S_SOCK -> Ok `Unix_socket + | S_REG -> Ok `Normal_file + | _ -> Ok `Other)) (fun e -> Lwt.return (Error e)) ;; end) diff --git a/otherlibs/dune-rpc-lwt/test/dune_rpc_lwt_tests.ml b/otherlibs/dune-rpc-lwt/test/dune_rpc_lwt_tests.ml index b9d09a6949f..f4a4ff63307 100644 --- a/otherlibs/dune-rpc-lwt/test/dune_rpc_lwt_tests.ml +++ b/otherlibs/dune-rpc-lwt/test/dune_rpc_lwt_tests.ml @@ -65,17 +65,17 @@ let build_watch ~root_dir = let run_with_timeout f = Lwt.catch (fun () -> - let+ () = - Lwt_unix.with_timeout 3.0 (fun () -> - let+ _ = f () in - ()) - in - print_endline "success") + let+ () = + Lwt_unix.with_timeout 3.0 (fun () -> + let+ _ = f () in + ()) + in + print_endline "success") (fun exn -> - (match exn with - | Lwt_unix.Timeout -> print_endline "timeout" - | _ -> ()); - Lwt.return_unit) + (match exn with + | Lwt_unix.Timeout -> print_endline "timeout" + | _ -> ()); + Lwt.return_unit) ;; let initial_cwd = Sys.getcwd () @@ -125,8 +125,8 @@ let%expect_test "run and connect" = Lwt.finalize (fun () -> run_with_timeout (fun () -> Lwt.all [ run_client; run_build ])) (fun () -> - build#terminate; - Lwt.return_unit)); + build#terminate; + Lwt.return_unit)); [%expect {| started session diff --git a/otherlibs/dune-rpc/private/conv.ml b/otherlibs/dune-rpc/private/conv.ml index 457692de9b5..40f728c87ec 100644 --- a/otherlibs/dune-rpc/private/conv.ml +++ b/otherlibs/dune-rpc/private/conv.ml @@ -129,7 +129,8 @@ type ('a, 'kind) t = | Version : ('a, 'kind) t * version -> ('a, 'kind) t | Both : (* Invariant: field names must be different *) - ('a, fields) t * ('b, fields) t + ('a, fields) t + * ('b, fields) t -> ('a * 'b, fields) t | Sexp : (Sexp.t, values) t | List : ('a, values) t -> ('a list, values) t @@ -141,7 +142,8 @@ type ('a, 'kind) t = | Fdecl : int * ('a, 'k) t Fdecl.t -> ('a, 'k) t | Either : (* Invariant: field names must be different *) - ('a, fields) t * ('b, fields) t + ('a, fields) t + * ('b, fields) t -> (('a, 'b) Either.t, fields) t | Record : ('a, fields) t -> ('a, values) t @@ -199,56 +201,56 @@ let char = Char let sexp_for_digest t = let rec iter : type a b. int list -> (a, b) t -> Sexp.t = fun ids -> function - | String -> Atom "String" - | Int -> Atom "Int" - | Float -> Atom "Float" - | Unit -> Atom "Unit" - | Char -> Atom "Char" - | Iso (t, _, _) -> List [ Atom "Iso"; iter ids t ] - | Iso_result (t, _, _) -> List [ Atom "Iso_result"; iter ids t ] - | Version (t, { since = a, b; until }) -> - let items : Sexp.t list = - [ Atom "Version" - ; iter ids t - ; List [ Atom "since"; Atom (Int.to_string a); Atom (Int.to_string b) ] - ] - in - let items = - match until with - | None -> items - | Some (a, b) -> - items - @ [ List [ Atom "until"; Atom (Int.to_string a); Atom (Int.to_string b) ] ] - in - List items - | Both (a, b) -> List [ Atom "Both"; iter ids a; iter ids b ] - | Sexp -> Atom "Sexp" - | List t -> List [ Atom "List"; iter ids t ] - | Field (name, field) -> - let field : Sexp.t = - match field with - | Required t -> List [ Atom "Required"; iter ids t ] - | Optional t -> List [ Atom "Optional"; iter ids t ] - in - List [ Atom "Field"; Atom name; field ] - | Enum cases -> - List (Atom "Enum" :: List.map cases ~f:(fun (name, _) : Sexp.t -> Atom name)) - | Sum (constrs, _) -> - List - (Atom "Sum" - :: List.map constrs ~f:(fun (Constr { name; arg; inj = _ }) : Sexp.t -> - List [ Atom name; iter ids arg ])) - | Pair (a, b) -> List [ Atom "Pair"; iter ids a; iter ids b ] - | Triple (a, b, c) -> List [ Atom "Triple"; iter ids a; iter ids b; iter ids c ] - | Fdecl (id, fdecl) -> - (* Although the id is represented as an auto-incrementing integer, we + | String -> Atom "String" + | Int -> Atom "Int" + | Float -> Atom "Float" + | Unit -> Atom "Unit" + | Char -> Atom "Char" + | Iso (t, _, _) -> List [ Atom "Iso"; iter ids t ] + | Iso_result (t, _, _) -> List [ Atom "Iso_result"; iter ids t ] + | Version (t, { since = a, b; until }) -> + let items : Sexp.t list = + [ Atom "Version" + ; iter ids t + ; List [ Atom "since"; Atom (Int.to_string a); Atom (Int.to_string b) ] + ] + in + let items = + match until with + | None -> items + | Some (a, b) -> + items + @ [ List [ Atom "until"; Atom (Int.to_string a); Atom (Int.to_string b) ] ] + in + List items + | Both (a, b) -> List [ Atom "Both"; iter ids a; iter ids b ] + | Sexp -> Atom "Sexp" + | List t -> List [ Atom "List"; iter ids t ] + | Field (name, field) -> + let field : Sexp.t = + match field with + | Required t -> List [ Atom "Required"; iter ids t ] + | Optional t -> List [ Atom "Optional"; iter ids t ] + in + List [ Atom "Field"; Atom name; field ] + | Enum cases -> + List (Atom "Enum" :: List.map cases ~f:(fun (name, _) : Sexp.t -> Atom name)) + | Sum (constrs, _) -> + List + (Atom "Sum" + :: List.map constrs ~f:(fun (Constr { name; arg; inj = _ }) : Sexp.t -> + List [ Atom name; iter ids arg ])) + | Pair (a, b) -> List [ Atom "Pair"; iter ids a; iter ids b ] + | Triple (a, b, c) -> List [ Atom "Triple"; iter ids a; iter ids b; iter ids c ] + | Fdecl (id, fdecl) -> + (* Although the id is represented as an auto-incrementing integer, we find De Bruijn indices to put in the digest so that equivalent structures produce the same digest. *) - (match List.findi ids ~f:(Int.equal id) with - | Some (_, index) -> List [ Atom "Recurse"; Atom (Int.to_string index) ] - | None -> List [ Atom "Fixpoint"; iter (id :: ids) (Fdecl.get fdecl) ]) - | Either (a, b) -> List [ Atom "Either"; iter ids a; iter ids b ] - | Record t -> List [ Atom "Record"; iter ids t ] + (match List.findi ids ~f:(Int.equal id) with + | Some (_, index) -> List [ Atom "Recurse"; Atom (Int.to_string index) ] + | None -> List [ Atom "Fixpoint"; iter (id :: ids) (Fdecl.get fdecl) ]) + | Either (a, b) -> List [ Atom "Either"; iter ids a; iter ids b ] + | Record t -> List [ Atom "Record"; iter ids t ] in iter [] t ;; @@ -313,11 +315,12 @@ let to_sexp : 'a. ('a, values) t -> 'a -> Sexp.t = ;; let check_version ~version ~since ~until _ctx = - if version < since - || - match until with - | None -> false - | Some until -> version > until + if + version < since + || + match until with + | None -> false + | Some until -> version > until then raise_version_error ?until ~since "invalid version" ;; diff --git a/otherlibs/dune-rpc/private/dune_rpc_private.ml b/otherlibs/dune-rpc/private/dune_rpc_private.ml index 3feb7af12ab..57c3638ebd6 100644 --- a/otherlibs/dune-rpc/private/dune_rpc_private.ml +++ b/otherlibs/dune-rpc/private/dune_rpc_private.ml @@ -215,7 +215,8 @@ module Client = struct ( Id.t , [ `Cancelled | `Pending of - [ `Completed of Response.t | `Connection_dead | `Cancelled ] Fiber.Ivar.t + [ `Completed of Response.t | `Connection_dead | `Cancelled ] + Fiber.Ivar.t ] ) Table.t ; initialize : Initialize.Request.t @@ -253,20 +254,20 @@ module Client = struct Fiber.fork_and_join_unit (fun () -> Chan.write t.chan None) (fun () -> - Fiber.parallel_iter ivars ~f:(fun status -> - match status with - | `Cancelled -> Fiber.return () - | `Pending ivar -> Fiber.Ivar.fill ivar `Connection_dead)) + Fiber.parallel_iter ivars ~f:(fun status -> + match status with + | `Cancelled -> Fiber.return () + | `Pending ivar -> Fiber.Ivar.fill ivar `Connection_dead)) ;; let terminate_with_error t message info = Fiber.fork_and_join_unit (fun () -> terminate t) (fun () -> - (* TODO stop using code error here. If [terminate_with_error] is + (* TODO stop using code error here. If [terminate_with_error] is called, it's because the other side is doing something unexpected, not because we have a bug *) - Code_error.raise message info) + Code_error.raise message info) ;; let send conn (packet : Packet.t list option) = @@ -374,11 +375,11 @@ module Client = struct ;; let make_notification - (type a) - t - ({ encode } : a Versioned.notification) - (n : a) - (k : Call.t -> 'a) + (type a) + t + ({ encode } : a Versioned.notification) + (n : a) + (k : Call.t -> 'a) : 'a = let call = encode n in @@ -511,11 +512,11 @@ module Client = struct ;; let request - (type a b) - ?id - t - ({ encode_req; decode_resp } : (a, b) Versioned.request) - (req : a) + (type a b) + ?id + t + ({ encode_req; decode_resp } : (a, b) Versioned.request) + (req : a) : (b, _) result Fiber.t = let* () = Fiber.return () in @@ -545,8 +546,9 @@ module Client = struct let* () = Fiber.parallel_iter packets ~f:(function | Packet.Notification n -> - if String.equal n.method_ Procedures.Server_side.abort.decl.method_ - && not t.handler_initialized + if + String.equal n.method_ Procedures.Server_side.abort.decl.method_ + && not t.handler_initialized then ( match Conv.of_sexp ~version:t.initialize.dune_version Message.sexp n.params @@ -660,11 +662,11 @@ module Client = struct ;; let connect_raw - chan - (initialize : Initialize.Request.t) - ~(private_menu : proc list) - ~(handler : Handler.t) - ~f + chan + (initialize : Initialize.Request.t) + ~(private_menu : proc list) + ~(handler : Handler.t) + ~f = let packets () = let+ read = Chan.read chan in diff --git a/otherlibs/dune-rpc/private/types.ml b/otherlibs/dune-rpc/private/types.ml index 403399787ce..9d1fcae9946 100644 --- a/otherlibs/dune-rpc/private/types.ml +++ b/otherlibs/dune-rpc/private/types.ml @@ -256,8 +256,7 @@ module Version_negotiation = struct iso (list (pair Method.Name.sexp (list Method.Version.sexp))) (fun x -> Menu x) - (function - | Menu x -> x)) + (function Menu x -> x)) ;; let to_call t = @@ -282,8 +281,7 @@ module Version_negotiation = struct iso (list (pair Method.Name.sexp Method.Version.sexp)) (fun x -> Selected x) - (function - | Selected x -> x)) + (function Selected x -> x)) ;; let create x = Selected x @@ -372,11 +370,11 @@ module Packet = struct iso (both method_ params) (fun (method_, params) -> - match method_, params with - | Some method_, Some params -> Some { Call.method_; params } - | None, None -> None - | Some _, None | None, Some _ -> - Conv.error (Parse_error { message = "invalid call"; payload = [] })) + match method_, params with + | Some method_, Some params -> Some { Call.method_; params } + | None, None -> None + | Some _, None | None, Some _ -> + Conv.error (Parse_error { message = "invalid call"; payload = [] })) (function | Some { Call.method_; params } -> Some method_, Some params | None -> None, None) @@ -413,13 +411,13 @@ module Decl = struct type ('req, 'resp) gen = Method.Version.t * ('req, 'resp) Generation.t let make_gen - ~req - ~resp - ~upgrade_req - ~downgrade_req - ~upgrade_resp - ~downgrade_resp - ~version + ~req + ~resp + ~upgrade_req + ~downgrade_req + ~upgrade_resp + ~downgrade_resp + ~version = ( version , Generation.T @@ -476,11 +474,11 @@ module Decl = struct type 'payload gen = Method.Version.t * ('payload, unit) Generation.t let make_gen - (type a b) - ~(conv : a Conv.value) - ~(upgrade : a -> b) - ~(downgrade : b -> a) - ~version + (type a b) + ~(conv : a Conv.value) + ~(upgrade : a -> b) + ~(downgrade : b -> a) + ~version : b gen = ( version diff --git a/otherlibs/dune-rpc/private/versioned.ml b/otherlibs/dune-rpc/private/versioned.ml index 5d27249cb5b..761e0ada308 100644 --- a/otherlibs/dune-rpc/private/versioned.ml +++ b/otherlibs/dune-rpc/private/versioned.ml @@ -217,18 +217,18 @@ module Make (Fiber : Fiber_intf.S) = struct all related operations (declaring, implementing, dispatching) share uniform implementations as much as possible. *) type (_, _, _) field_witness = - | Declared_requests - : ( _ - , Method.Name.t - * ('req, 'resp) Decl.Generation.t Method.Version.Map.t Univ_map.Key.t - , ('req, 'resp) Decl.Generation.t ) - field_witness - | Declared_notifs - : ( _ - , Method.Name.t - * ('a, unit) Decl.Generation.t Method.Version.Map.t Univ_map.Key.t - , ('a, unit) Decl.Generation.t ) - field_witness + | Declared_requests : + ( _ + , Method.Name.t + * ('req, 'resp) Decl.Generation.t Method.Version.Map.t Univ_map.Key.t + , ('req, 'resp) Decl.Generation.t ) + field_witness + | Declared_notifs : + ( _ + , Method.Name.t + * ('a, unit) Decl.Generation.t Method.Version.Map.t Univ_map.Key.t + , ('a, unit) Decl.Generation.t ) + field_witness | Impl_requests : ('state, string, 'state r_handler) field_witness | Impl_notifs : ('state, string, 'state n_handler) field_witness @@ -249,11 +249,11 @@ module Make (Fiber : Fiber_intf.S) = struct ;; let set - (type st a b) - (t : st t) - (witness : (st, a, b) field_witness) - (key : a) - (value : b Method.Version.Map.t) + (type st a b) + (t : st t) + (witness : (st, a, b) field_witness) + (key : a) + (value : b Method.Version.Map.t) = match witness with | Declared_requests -> @@ -271,11 +271,12 @@ module Make (Fiber : Fiber_intf.S) = struct ;; let registered_procedures - { declared_requests = declared_request_keys, declared_request_table - ; declared_notifications = declared_notification_keys, declared_notification_table - ; implemented_requests - ; implemented_notifications - } + { declared_requests = declared_request_keys, declared_request_table + ; declared_notifications = + declared_notification_keys, declared_notification_table + ; implemented_requests + ; implemented_notifications + } = let batch_declarations which declared_keys declaration_table = Method.Name.Map.foldi declared_keys ~init:[] ~f:(fun name keys acc -> @@ -329,14 +330,14 @@ module Make (Fiber : Fiber_intf.S) = struct ;; let register_generic - t - ~method_ - ~generations - ~registry - ~registry_key - ~other - ~other_key - ~pack + t + ~method_ + ~generations + ~registry + ~registry_key + ~other + ~other_key + ~pack = let () = get t other other_key @@ -441,19 +442,19 @@ module Make (Fiber : Fiber_intf.S) = struct ~method_:n.method_ (fun e -> Fiber.return (Error (Version_error.to_response_error e))) (fun (handlers, version) -> - match Method.Version.Map.find handlers version with - | None -> - raise_version_bug - ~method_:n.method_ - ~selected:version - ~verb:"unimplemented" - ~known:(Method.Version.Map.keys handlers) - | Some (R (f, T gen)) -> - (match Conv.of_sexp gen.req ~version:(session_version state) n.params with - | Error e -> Fiber.return (Error (Response.Error.of_conv e)) - | Ok req -> - let+ resp = f state (gen.upgrade_req req) in - Ok (Conv.to_sexp gen.resp (gen.downgrade_resp resp)))) + match Method.Version.Map.find handlers version with + | None -> + raise_version_bug + ~method_:n.method_ + ~selected:version + ~verb:"unimplemented" + ~known:(Method.Version.Map.keys handlers) + | Some (R (f, T gen)) -> + (match Conv.of_sexp gen.req ~version:(session_version state) n.params with + | Error e -> Fiber.return (Error (Response.Error.of_conv e)) + | Ok req -> + let+ resp = f state (gen.upgrade_req req) in + Ok (Conv.to_sexp gen.resp (gen.downgrade_resp resp)))) in let handle_notification menu state (n : Call.t) = lookup_method_generic @@ -464,19 +465,19 @@ module Make (Fiber : Fiber_intf.S) = struct ~method_:n.method_ (fun e -> Fiber.return (Error (Version_error.to_response_error e))) (fun (handlers, version) -> - match Method.Version.Map.find handlers version with - | None -> - raise_version_bug - ~method_:n.method_ - ~selected:version - ~verb:"unimplemented" - ~known:(Method.Version.Map.keys handlers) - | Some (N (f, T gen)) -> - (match Conv.of_sexp gen.req ~version:(session_version state) n.params with - | Error e -> Fiber.return (Error (Response.Error.of_conv e)) - | Ok req -> - let+ () = f state (gen.upgrade_req req) in - Ok ())) + match Method.Version.Map.find handlers version with + | None -> + raise_version_bug + ~method_:n.method_ + ~selected:version + ~verb:"unimplemented" + ~known:(Method.Version.Map.keys handlers) + | Some (N (f, T gen)) -> + (match Conv.of_sexp gen.req ~version:(session_version state) n.params with + | Error e -> Fiber.return (Error (Response.Error.of_conv e)) + | Ok req -> + let+ () = f state (gen.upgrade_req req) in + Ok ())) in let prepare_request (type a b) menu (decl : (a, b) Decl.Request.witness) : ((a, b) Staged.request, Version_error.t) result @@ -490,23 +491,23 @@ module Make (Fiber : Fiber_intf.S) = struct ~method_ (fun e -> Error e) (fun (decls, version) -> - match Method.Version.Map.find decls version with - | None -> - raise_version_bug - ~method_ - ~selected:version - ~verb:"undeclared" - ~known:(Method.Version.Map.keys decls) - | Some (T gen) -> - let encode_req (req : a) = - { Call.method_; params = Conv.to_sexp gen.req (gen.downgrade_req req) } - in - let decode_resp sexp = - match Conv.of_sexp gen.resp ~version:(3, 0) sexp with - | Ok resp -> Ok (gen.upgrade_resp resp) - | Error e -> Error (Response.Error.of_conv e) - in - Ok { Staged.encode_req; decode_resp }) + match Method.Version.Map.find decls version with + | None -> + raise_version_bug + ~method_ + ~selected:version + ~verb:"undeclared" + ~known:(Method.Version.Map.keys decls) + | Some (T gen) -> + let encode_req (req : a) = + { Call.method_; params = Conv.to_sexp gen.req (gen.downgrade_req req) } + in + let decode_resp sexp = + match Conv.of_sexp gen.resp ~version:(3, 0) sexp with + | Ok resp -> Ok (gen.upgrade_resp resp) + | Error e -> Error (Response.Error.of_conv e) + in + Ok { Staged.encode_req; decode_resp }) in let prepare_notification (type a) menu (decl : a Decl.Notification.witness) : (a Staged.notification, Version_error.t) result @@ -520,18 +521,18 @@ module Make (Fiber : Fiber_intf.S) = struct ~method_ (fun e -> Error e) (fun (decls, version) -> - match Method.Version.Map.find decls version with - | None -> - raise_version_bug - ~method_ - ~selected:version - ~verb:"undeclared" - ~known:(Method.Version.Map.keys decls) - | Some (T gen) -> - let encode (req : a) = - { Call.method_; params = Conv.to_sexp gen.req (gen.downgrade_req req) } - in - Ok { Staged.encode }) + match Method.Version.Map.find decls version with + | None -> + raise_version_bug + ~method_ + ~selected:version + ~verb:"undeclared" + ~known:(Method.Version.Map.keys decls) + | Some (T gen) -> + let encode (req : a) = + { Call.method_; params = Conv.to_sexp gen.req (gen.downgrade_req req) } + in + Ok { Staged.encode }) in fun ~menu -> { Handler.menu diff --git a/otherlibs/dune-site/src/plugins/plugins.ml b/otherlibs/dune-site/src/plugins/plugins.ml index 654bf68f7d3..5e434d780a3 100644 --- a/otherlibs/dune-site/src/plugins/plugins.ml +++ b/otherlibs/dune-site/src/plugins/plugins.ml @@ -13,9 +13,9 @@ let readdir = List.concat (List.map (fun dir -> - List.filter - (fun entry -> Sys.file_exists (dir / entry / meta_fn)) - (Array.to_list (readdir_noexn dir))) + List.filter + (fun entry -> Sys.file_exists (dir / entry / meta_fn)) + (Array.to_list (readdir_noexn dir))) dirs) ;; @@ -273,8 +273,8 @@ let load_gen ~load_requires dirs name = List.iter load_requires requires; List.iter (fun p -> - let file = Filename.concat directory p in - Dune_site_backend.Linker.load file) + let file = Filename.concat directory p in + Dune_site_backend.Linker.load file) plugins) ;; diff --git a/otherlibs/ocamlc-loc/test/ocamlc_loc_tests.ml b/otherlibs/ocamlc-loc/test/ocamlc_loc_tests.ml index 10070c42498..bf31044f151 100644 --- a/otherlibs/ocamlc-loc/test/ocamlc_loc_tests.ml +++ b/otherlibs/ocamlc-loc/test/ocamlc_loc_tests.ml @@ -3,8 +3,8 @@ open Stdune let cmd fmt = Printf.ksprintf (fun s -> - let (_ : int) = Sys.command s in - ()) + let (_ : int) = Sys.command s in + ()) fmt ;; @@ -325,10 +325,12 @@ Error: Some record fields are undefined: signal_watcher ;; let%expect_test "undefined fields" = - test_error_raw {| + test_error_raw + {| Error: Some record fields are undefined: signal_watcher |}; - [%expect {| + [%expect + {| [ "Error: Some record fields are undefined: signal_watcher" ] |}] ;; diff --git a/otherlibs/stdune/dune_filesystem_stubs/dune_filesystem_stubs.ml b/otherlibs/stdune/dune_filesystem_stubs/dune_filesystem_stubs.ml index bdb682979ee..3276451fc7e 100644 --- a/otherlibs/stdune/dune_filesystem_stubs/dune_filesystem_stubs.ml +++ b/otherlibs/stdune/dune_filesystem_stubs/dune_filesystem_stubs.ml @@ -277,25 +277,25 @@ let read_directory_with_kinds_exn dir_path = Fun.protect ~finally:(fun () -> Unix.closedir dir) (fun () -> - let rec loop acc = - match readdir_with_kind_if_available dir with - | Entry (("." | ".."), _) -> loop acc - | End_of_directory -> acc - | Entry (base, kind) -> - let k kind = loop ((base, kind) :: acc) in - let skip () = loop acc in - File_kind.Option.elim - kind - ~none:(fun () -> - match Unix.lstat (Filename.concat dir_path base) with - | exception Unix.Unix_error _ -> - (* File disappeared between readdir & lstat system calls. Handle + let rec loop acc = + match readdir_with_kind_if_available dir with + | Entry (("." | ".."), _) -> loop acc + | End_of_directory -> acc + | Entry (base, kind) -> + let k kind = loop ((base, kind) :: acc) in + let skip () = loop acc in + File_kind.Option.elim + kind + ~none:(fun () -> + match Unix.lstat (Filename.concat dir_path base) with + | exception Unix.Unix_error _ -> + (* File disappeared between readdir & lstat system calls. Handle as if readdir never told us about it *) - skip () - | stat -> k stat.st_kind) - ~some:k - in - loop []) + skip () + | stat -> k stat.st_kind) + ~some:k + in + loop []) ;; let read_directory_with_kinds dir_path = @@ -307,13 +307,13 @@ let read_directory_exn dir_path = Fun.protect ~finally:(fun () -> Unix.closedir dir) (fun () -> - let rec loop acc = - match readdir_with_kind_if_available dir with - | Entry (("." | ".."), _) -> loop acc - | End_of_directory -> acc - | Entry (base, _) -> loop (base :: acc) - in - loop []) + let rec loop acc = + match readdir_with_kind_if_available dir with + | Entry (("." | ".."), _) -> loop acc + | End_of_directory -> acc + | Entry (base, _) -> loop (base :: acc) + in + loop []) ;; let read_directory dir_path = Unix_error.Detailed.catch read_directory_exn dir_path diff --git a/otherlibs/stdune/src/fpath.ml b/otherlibs/stdune/src/fpath.ml index c9206c40667..740ebcf4539 100644 --- a/otherlibs/stdune/src/fpath.ml +++ b/otherlibs/stdune/src/fpath.ml @@ -3,8 +3,7 @@ let is_root = then fun x -> x = "/" || x = "." else (* CR-someday rgrinberg: can we do better on windows? *) - fun s -> - Filename.dirname s = s + fun s -> Filename.dirname s = s ;; let initial_cwd = Stdlib.Sys.getcwd () diff --git a/otherlibs/stdune/src/lexbuf.ml b/otherlibs/stdune/src/lexbuf.ml index 16c03282221..d9386cb2440 100644 --- a/otherlibs/stdune/src/lexbuf.ml +++ b/otherlibs/stdune/src/lexbuf.ml @@ -4,8 +4,8 @@ module Position = struct type t = Lexing.position let equal - { Lexing.pos_fname = f_a; pos_lnum = l_a; pos_bol = b_a; pos_cnum = c_a } - { Lexing.pos_fname = f_b; pos_lnum = l_b; pos_bol = b_b; pos_cnum = c_b } + { Lexing.pos_fname = f_a; pos_lnum = l_a; pos_bol = b_a; pos_cnum = c_a } + { Lexing.pos_fname = f_b; pos_lnum = l_b; pos_bol = b_b; pos_cnum = c_b } = f_a = f_b && l_a = l_b && b_a = b_b && c_a = c_b ;; diff --git a/otherlibs/stdune/src/map.ml b/otherlibs/stdune/src/map.ml index 5bf26d1732f..afb67dd5e8e 100644 --- a/otherlibs/stdune/src/map.ml +++ b/otherlibs/stdune/src/map.ml @@ -28,8 +28,8 @@ module Make (Key : Key) : S with type key = Key.t = struct try Result.Ok (update t key ~f:(function - | None -> Some v - | Some e -> raise_notrace (M.Found e))) + | None -> Some v + | Some e -> raise_notrace (M.Found e))) with | M.Found e -> Error e ;; diff --git a/otherlibs/stdune/src/sys.ml b/otherlibs/stdune/src/sys.ml index 2e0258a4039..afb5ebabd5b 100644 --- a/otherlibs/stdune/src/sys.ml +++ b/otherlibs/stdune/src/sys.ml @@ -2,12 +2,13 @@ include Stdlib.Sys let force_remove = if win32 - then (fun fn -> - try remove fn with - | Sys_error _ -> - (* Try to remove the "read-only" attribute, then retry. *) - (try Unix.chmod fn 0o666 with - | Unix.Unix_error _ -> ()); - remove fn) + then ( + fun fn -> + try remove fn with + | Sys_error _ -> + (* Try to remove the "read-only" attribute, then retry. *) + (try Unix.chmod fn 0o666 with + | Unix.Unix_error _ -> ()); + remove fn) else remove ;; diff --git a/otherlibs/stdune/test/appendable_list_tests.ml b/otherlibs/stdune/test/appendable_list_tests.ml index 11147ede814..622d218310f 100644 --- a/otherlibs/stdune/test/appendable_list_tests.ml +++ b/otherlibs/stdune/test/appendable_list_tests.ml @@ -15,7 +15,8 @@ let%expect_test "singleton" = let%expect_test "cons" = print (List.fold_right [ "a"; "b"; "c"; "d" ] ~init:Al.empty ~f:Al.cons); - [%expect {| + [%expect + {| a b c @@ -25,14 +26,16 @@ let%expect_test "cons" = let%expect_test "append" = print Al.(singleton "a" @ (singleton "b" @ singleton "c") @ singleton "d" @ singleton "e"); - [%expect {| + [%expect + {| a b c d e |}]; print Al.(cons "a" (cons "b" (cons "c" empty)) @ cons "d" (cons "e" (cons "f" empty))); - [%expect {| + [%expect + {| a b c @@ -43,7 +46,8 @@ let%expect_test "append" = let%expect_test "concat" = print (Al.concat (List.init 10 ~f:(fun i -> Al.singleton (Int.to_string i)))); - [%expect {| + [%expect + {| 0 1 2 diff --git a/otherlibs/stdune/test/bytes_unit_tests.ml b/otherlibs/stdune/test/bytes_unit_tests.ml index c9b199472c5..f13f53d6279 100644 --- a/otherlibs/stdune/test/bytes_unit_tests.ml +++ b/otherlibs/stdune/test/bytes_unit_tests.ml @@ -62,7 +62,8 @@ let%expect_test "Testing significant digit boundaries" = (* Negative units get truncated but still printed as a negative. *) let%expect_test "Negative units" = test [ -1L; -10L ]; - [%expect {| + [%expect + {| -0.00TB -0.00TB |}] diff --git a/otherlibs/stdune/test/filename_tests.ml b/otherlibs/stdune/test/filename_tests.ml index 372c859582e..06ec8a3951f 100644 --- a/otherlibs/stdune/test/filename_tests.ml +++ b/otherlibs/stdune/test/filename_tests.ml @@ -6,14 +6,16 @@ let extension s = print (Pp.text (Filename.extension s)) let%expect_test _ = extension "toto.titi"; - [%expect {| + [%expect + {| .titi |}] ;; let%expect_test _ = extension "toto."; - [%expect {| + [%expect + {| . |}] ;; @@ -35,21 +37,24 @@ let%expect_test _ = let%expect_test _ = extension "a."; - [%expect {| + [%expect + {| . |}] ;; let%expect_test _ = extension "a.a"; - [%expect {| + [%expect + {| .a |}] ;; let%expect_test _ = extension "truc/a.a"; - [%expect {| + [%expect + {| .a |}] ;; @@ -61,7 +66,8 @@ let%expect_test _ = let%expect_test _ = extension "truc/a."; - [%expect {| + [%expect + {| . |}] ;; diff --git a/otherlibs/stdune/test/io_tests.ml b/otherlibs/stdune/test/io_tests.ml index d4354faab85..0f36f55819e 100644 --- a/otherlibs/stdune/test/io_tests.ml +++ b/otherlibs/stdune/test/io_tests.ml @@ -31,7 +31,8 @@ let%expect_test "copy file chmod" = Io.copy_file ~chmod:(fun _ -> 428) ~src ~dst (); print_endline (Io.read_file dst); Printf.printf "permissions: %d\n" (Path.stat_exn dst).st_perm; - [%expect {| + [%expect + {| foobarbaz permissions: 428 |}] ;; diff --git a/otherlibs/stdune/test/loc_tests.ml b/otherlibs/stdune/test/loc_tests.ml index 2e7b1afc2f5..7fd81881ce6 100644 --- a/otherlibs/stdune/test/loc_tests.ml +++ b/otherlibs/stdune/test/loc_tests.ml @@ -3,7 +3,9 @@ open Stdune let%expect_test "#7905 - inverted char offsets" = let dir = Temp.create Dir ~prefix:"" ~suffix:"loc" in let file = Path.relative dir "file.ml" in - Io.write_file file {| + Io.write_file + file + {| type t = A | B let f () () = function @@ -19,7 +21,8 @@ let f () () = function in Temp.destroy Dir file; print_endline output; - [%expect {| + [%expect + {| 4 | let f () () = function 5 | | A -> () |}] ;; diff --git a/otherlibs/stdune/test/map_tests.ml b/otherlibs/stdune/test/map_tests.ml index 61271e4600e..280089e7951 100644 --- a/otherlibs/stdune/test/map_tests.ml +++ b/otherlibs/stdune/test/map_tests.ml @@ -9,7 +9,8 @@ let%expect_test _ = String.Map.of_list_multi [ "a", 1; "b", 1; "a", 2; "a", 3; "b", 2 ] |> String.Map.to_dyn (list int) |> print_dyn; - [%expect {| + [%expect + {| map { "a" : [ 1; 2; 3 ]; "b" : [ 1; 2 ] } |}] ;; diff --git a/otherlibs/stdune/test/path_tests.ml b/otherlibs/stdune/test/path_tests.ml index c8db7d45e61..bfbd1e4fc24 100644 --- a/otherlibs/stdune/test/path_tests.ml +++ b/otherlibs/stdune/test/path_tests.ml @@ -42,7 +42,8 @@ let local_part p = Path.local_part p |> Path.Local.to_dyn |> print_dyn let%expect_test _ = let p = Path.(relative root) "foo" in descendant p ~of_:p; - [%expect {| + [%expect + {| Some (In_source_tree ".") |}] ;; @@ -50,399 +51,456 @@ let%expect_test _ = let%expect_test _ = (* different strings but same length *) descendant (r "foo") ~of_:(r "bar"); - [%expect {| + [%expect + {| None |}] ;; let%expect_test _ = is_descendant (r "foo") ~of_:(r "foo"); - [%expect {| + [%expect + {| true |}] ;; let%expect_test _ = is_descendant (r "foo") ~of_:(r "foo/"); - [%expect {| + [%expect + {| true |}] ;; let%expect_test _ = is_descendant (r "foo/") ~of_:(r "foo"); - [%expect {| + [%expect + {| true |}] ;; let%expect_test _ = is_descendant (r "foo") ~of_:(r "bar"); - [%expect {| + [%expect + {| false |}] ;; let%expect_test _ = is_descendant (r "foo") ~of_:(r "bar/"); - [%expect {| + [%expect + {| false |}] ;; let%expect_test _ = is_descendant (r "foo/") ~of_:(r "bar"); - [%expect {| + [%expect + {| false |}] ;; let%expect_test _ = is_descendant (r "glob/foo") ~of_:(r "glob"); - [%expect {| + [%expect + {| true |}] ;; let%expect_test _ = is_descendant (r "glob/foo") ~of_:(r "glob/"); - [%expect {| + [%expect + {| true |}] ;; let%expect_test _ = is_descendant (e "/foo/bar") ~of_:(e "/foo"); - [%expect {| + [%expect + {| false |}] ;; let%expect_test _ = is_descendant (e "/foo/bar") ~of_:(e "/foo/bar"); - [%expect {| + [%expect + {| false |}] ;; let%expect_test _ = is_descendant (e "/foo/bar") ~of_:(e "/foo/bar/"); - [%expect {| + [%expect + {| false |}] ;; let%expect_test _ = is_descendant (e "/foo/bar/") ~of_:(e "/foo/bar"); - [%expect {| + [%expect + {| false |}] ;; let%expect_test _ = is_descendant (e "/foo/bar") ~of_:(e "/"); - [%expect {| + [%expect + {| false |}] ;; let%expect_test _ = descendant (r "foo") ~of_:(r "foo/"); - [%expect {| + [%expect + {| Some (In_source_tree ".") |}] ;; let%expect_test _ = descendant (r "foo/") ~of_:(r "foo"); - [%expect {| + [%expect + {| Some (In_source_tree ".") |}] ;; let%expect_test _ = descendant (r "foo/bar") ~of_:(r "foo"); - [%expect {| + [%expect + {| Some (In_source_tree "bar") |}] ;; let%expect_test _ = descendant Path.root ~of_:(r "foo"); - [%expect {| + [%expect + {| None |}] ;; let%expect_test _ = descendant Path.root ~of_:Path.root; - [%expect {| + [%expect + {| Some (In_source_tree ".") |}] ;; let%expect_test _ = descendant (r "foo") ~of_:Path.root; - [%expect {| + [%expect + {| Some (In_source_tree "foo") |}] ;; let%expect_test _ = descendant (Path.relative build_dir "foo") ~of_:root; - [%expect {| + [%expect + {| None |}] ;; let%expect_test _ = descendant (Path.relative build_dir "foo") ~of_:(Path.of_string "/foo/bar"); - [%expect {| + [%expect + {| None |}] ;; let%expect_test _ = descendant (Path.relative build_dir "foo/bar") ~of_:build_dir; - [%expect {| + [%expect + {| Some (In_source_tree "foo/bar") |}] ;; let%expect_test _ = descendant (Path.relative build_dir "foo/bar") ~of_:(Path.relative build_dir "foo"); - [%expect {| + [%expect + {| Some (In_source_tree "bar") |}] ;; let%expect_test _ = descendant (Path.relative build_dir "foo/bar") ~of_:(Path.relative build_dir "foo"); - [%expect {| + [%expect + {| Some (In_source_tree "bar") |}] ;; let%expect_test _ = descendant (Path.of_string "/foo/bar") ~of_:(Path.of_string "/foo"); - [%expect {| + [%expect + {| None |}] ;; let%expect_test _ = explode "a/b/c"; - [%expect {| + [%expect + {| Some [ "a"; "b"; "c" ] |}] ;; let%expect_test _ = explode "a/b"; - [%expect {| + [%expect + {| Some [ "a"; "b" ] |}] ;; let%expect_test _ = explode "a"; - [%expect {| + [%expect + {| Some [ "a" ] |}] ;; let%expect_test _ = explode ""; - [%expect {| + [%expect + {| Some [] |}] ;; let%expect_test _ = reach "/foo/baz" ~from:"/foo/bar"; - [%expect {| + [%expect + {| "/foo/baz" |}] ;; let%expect_test _ = reach "/foo/bar" ~from:"baz"; - [%expect {| + [%expect + {| "/foo/bar" |}] ;; let%expect_test _ = reach "bar/foo" ~from:"bar/baz/y"; - [%expect {| + [%expect + {| "../../foo" |}] ;; let%expect_test _ = reach "foo" ~from:"foo"; - [%expect {| + [%expect + {| "." |}] ;; let%expect_test _ = reach "bar/foo" ~from:"bar/foo"; - [%expect {| + [%expect + {| "." |}] ;; let%expect_test _ = reach "a/b/x" ~from:"a/b/y"; - [%expect {| + [%expect + {| "../x" |}] ;; let%expect_test _ = reach "a/b" ~from:"a/b/x"; - [%expect {| + [%expect + {| ".." |}] ;; let%expect_test _ = reach "a/b/x" ~from:"a/b"; - [%expect {| + [%expect + {| "x" |}] ;; let%expect_test _ = reach "a/b/x/z" ~from:"a/b/y"; - [%expect {| + [%expect + {| "../x/z" |}] ;; let%expect_test _ = reach "a/b/y" ~from:"a/b/x/z"; - [%expect {| + [%expect + {| "../../y" |}] ;; let%expect_test _ = reach "a/bbb" ~from:"a/b"; - [%expect {| + [%expect + {| "../bbb" |}] ;; let%expect_test _ = reach "" ~from:""; - [%expect {| + [%expect + {| "." |}] ;; let%expect_test _ = reach "" ~from:"foo"; - [%expect {| + [%expect + {| ".." |}] ;; let%expect_test _ = reach "foo" ~from:""; - [%expect {| + [%expect + {| "foo" |}] ;; let%expect_test _ = reach "x/foo" ~from:"bar/x"; - [%expect {| + [%expect + {| "../../x/foo" |}] ;; let%expect_test _ = reach "a/x" ~from:"x/b"; - [%expect {| + [%expect + {| "../../a/x" |}] ;; let%expect_test _ = reach "default/META.foo" ~from:"default"; - [%expect {| + [%expect + {| "META.foo" |}] ;; let%expect_test _ = reach "default/av" ~from:"default/avdevice"; - [%expect {| + [%expect + {| "../av" |}] ;; let%expect_test _ = relative (Path.of_string "relative") "/absolute/path"; - [%expect {| + [%expect + {| External "/absolute/path" |}] ;; let%expect_test _ = relative (Path.of_string "/abs1") "/abs2"; - [%expect {| + [%expect + {| External "/abs2" |}] ;; let%expect_test _ = relative (of_string "/abs1") ""; - [%expect {| + [%expect + {| External "/abs1" |}] ;; let%expect_test _ = relative root "/absolute/path"; - [%expect {| + [%expect + {| External "/absolute/path" |}] ;; let%expect_test _ = of_filename_relative_to_initial_cwd "/absolute/path"; - [%expect {| + [%expect + {| External "/absolute/path" |}] ;; let%expect_test _ = Path.is_managed (e "relative/path") |> Dyn.bool |> print_dyn; - [%expect {| + [%expect + {| false |}] ;; let%expect_test _ = append_source Path.build_dir (Path.Source.relative Path.Source.root "foo"); - [%expect {| + [%expect + {| In_build_dir "foo" |}] ;; let%expect_test _ = append_source Path.root (Path.Source.relative Path.Source.root "foo"); - [%expect {| + [%expect + {| In_source_tree "foo" |}] ;; let%expect_test _ = append_source (Path.of_string "/root") (Path.Source.relative Path.Source.root "foo"); - [%expect {| + [%expect + {| External "/root/foo" |}] ;; @@ -458,49 +516,56 @@ let%expect_test _ = let%expect_test _ = drop_build_context (Path.relative Path.build_dir "foo/bar"); - [%expect {| + [%expect + {| Some (In_source_tree "bar") |}] ;; let%expect_test _ = drop_build_context (Path.of_string "foo/bar"); - [%expect {| + [%expect + {| None |}] ;; let%expect_test _ = drop_build_context (e "/foo/bar"); - [%expect {| + [%expect + {| None |}] ;; let%expect_test _ = drop_build_context Path.build_dir; - [%expect {| + [%expect + {| None |}] ;; let%expect_test _ = Path.is_in_build_dir Path.build_dir |> Dyn.bool |> print_dyn; - [%expect {| + [%expect + {| true |}] ;; let%expect_test _ = Path.is_strict_descendant_of_build_dir Path.build_dir |> Dyn.bool |> print_dyn; - [%expect {| + [%expect + {| false |}] ;; let%expect_test _ = Path.reach_for_running Path.build_dir ~from:Path.root |> Dyn.string |> print_dyn; - [%expect {| + [%expect + {| "./_build" |}] ;; @@ -509,28 +574,32 @@ let%expect_test _ = reach_for_running (Path.relative build_dir "foo/baz") ~from:(Path.relative build_dir "foo/bar/baz"); - [%expect {| + [%expect + {| "../../baz" |}] ;; let%expect_test _ = reach_for_running (e "/fake/path") ~from:(Path.relative build_dir "foo/bar/baz"); - [%expect {| + [%expect + {| "/fake/path" |}] ;; let%expect_test _ = reach_for_running (Path.relative root "foo") ~from:(Path.relative root "foo"); - [%expect {| + [%expect + {| "./." |}] ;; let%expect_test _ = relative Path.root "_build"; - [%expect {| + [%expect + {| In_build_dir "." |}] ;; @@ -538,21 +607,24 @@ In_build_dir "." let%expect_test _ = (* This is not right, but kind of annoying to fix :/ *) relative (r "foo") "../_build"; - [%expect {| + [%expect + {| In_build_dir "." |}] ;; let%expect_test _ = local_part (Path.of_string "/c/d"); - [%expect {| + [%expect + {| "c/d" |}] ;; let%expect_test _ = local_part (r "c/d"); - [%expect {| + [%expect + {| "c/d" |}] ;; @@ -561,7 +633,8 @@ let%expect_test _ = Path.Build.extract_first_component Path.Build.root |> Dyn.(option (pair string Local.to_dyn)) |> print_dyn; - [%expect {| + [%expect + {| None |}] ;; diff --git a/otherlibs/stdune/test/string_tests.ml b/otherlibs/stdune/test/string_tests.ml index bf52ecdb0f9..125be432eba 100644 --- a/otherlibs/stdune/test/string_tests.ml +++ b/otherlibs/stdune/test/string_tests.ml @@ -10,140 +10,160 @@ let split s ~on = String.split s ~on |> list string |> print_dyn let%expect_test _ = take "foobar" 3; - [%expect {| + [%expect + {| "foo" |}] ;; let%expect_test _ = take "foobar" 0; - [%expect {| + [%expect + {| "" |}] ;; let%expect_test _ = take "foo" 10; - [%expect {| + [%expect + {| "foo" |}] ;; let%expect_test _ = take "" 10; - [%expect {| + [%expect + {| "" |}] ;; let%expect_test _ = take "" 0; - [%expect {| + [%expect + {| "" |}] ;; let%expect_test _ = drop "" 0; - [%expect {| + [%expect + {| "" |}] ;; let%expect_test _ = drop "foo" 0; - [%expect {| + [%expect + {| "foo" |}] ;; let%expect_test _ = drop "foo" 5; - [%expect {| + [%expect + {| "" |}] ;; let%expect_test _ = drop "foobar" 3; - [%expect {| + [%expect + {| "bar" |}] ;; let%expect_test _ = split_n "foobar" 3; - [%expect {| + [%expect + {| ("foo", "bar") |}] ;; let%expect_test _ = split_n "foobar" 10; - [%expect {| + [%expect + {| ("foobar", "") |}] ;; let%expect_test _ = split_n "foobar" 0; - [%expect {| + [%expect + {| ("", "foobar") |}] ;; let%expect_test _ = split_n "foobar" 6; - [%expect {| + [%expect + {| ("foobar", "") |}] ;; let%expect_test _ = split_n "" 0; - [%expect {| + [%expect + {| ("", "") |}] ;; let%expect_test _ = split_n "" 10; - [%expect {| + [%expect + {| ("", "") |}] ;; let%expect_test _ = String.longest_prefix [ "food"; "foo"; "foo-bar" ] |> string |> print_dyn; - [%expect {| + [%expect + {| "foo" |}] ;; let%expect_test _ = String.drop_suffix "foobar" ~suffix:"bar" |> option string |> print_dyn; - [%expect {| + [%expect + {| Some "foo" |}] ;; let%expect_test _ = String.drop_suffix "foobar" ~suffix:"foobar" |> option string |> print_dyn; - [%expect {| + [%expect + {| Some "" |}] ;; let%expect_test _ = String.drop_suffix "foobar" ~suffix:"" |> option string |> print_dyn; - [%expect {| + [%expect + {| Some "foobar" |}] ;; let%expect_test _ = String.drop_suffix "foobar" ~suffix:"foo" |> option string |> print_dyn; - [%expect {| + [%expect + {| None |}] ;; diff --git a/otherlibs/stdune/test/temp_tests.ml b/otherlibs/stdune/test/temp_tests.ml index 9f471c9fc8f..5420ec3a7fe 100644 --- a/otherlibs/stdune/test/temp_tests.ml +++ b/otherlibs/stdune/test/temp_tests.ml @@ -13,7 +13,8 @@ let%expect_test "Temp.clear_dir works" = print (); Temp.clear_dir path; print (); - [%expect {| + [%expect + {| Ok [ "foo" ] Ok [] |}] diff --git a/src/0install-solver/diagnostics.ml b/src/0install-solver/diagnostics.ml index 8d932fd0c09..a9399c4a5b4 100644 --- a/src/0install-solver/diagnostics.ml +++ b/src/0install-solver/diagnostics.ml @@ -1,6 +1,6 @@ (* Copyright (C) 2013, Thomas Leonard * See the README file for details, or visit http://0install.net. - *) +*) (** Explaining why a solve failed or gave an unexpected answer. *) @@ -83,10 +83,10 @@ module Make (Results : S.SOLVER_RESULT) = struct is the selected implementation, or [None] if we chose [dummy_impl]. @param diagnostics can be used to produce diagnostics as a last resort. *) let create - ~role - (candidates, orig_bad, feed_problems) - (diagnostics : _ Pp.t Lazy.t) - (selected_impl : Model.impl option) + ~role + (candidates, orig_bad, feed_problems) + (diagnostics : _ Pp.t Lazy.t) + (selected_impl : Model.impl option) = let { Model.impls; Model.replacement } = candidates in let notes = List.map ~f:(fun x -> Note.Feed_problem x) feed_problems in @@ -382,11 +382,11 @@ module Make (Results : S.SOLVER_RESULT) = struct let classes = RoleMap.fold (fun role component acc -> - match Component.selected_impl component with - | None -> acc - | Some impl -> - Model.conflict_class impl - |> List.fold_left ~f:(fun acc x -> Classes.add x role acc) ~init:acc) + match Component.selected_impl component with + | None -> acc + | Some impl -> + Model.conflict_class impl + |> List.fold_left ~f:(fun acc x -> Classes.add x role acc) ~init:acc) report Classes.empty in diff --git a/src/0install-solver/sat.ml b/src/0install-solver/sat.ml index 18410e2f94e..ce6eea2ba0d 100644 --- a/src/0install-solver/sat.ml +++ b/src/0install-solver/sat.ml @@ -1,6 +1,6 @@ (* Copyright (C) 2013, Thomas Leonard * See the README file for details, or visit http://0install.net. - *) +*) (** A general purpose SAT solver. *) @@ -83,11 +83,11 @@ module Make (User : USER) = struct { id : VarID.t (* A unique ID, used to test identity *) ; mutable value : var_value (* True/False/Undecided *) ; mutable reason : reason option - (* The constraint that implied our value, if True or False *) + (* The constraint that implied our value, if True or False *) ; mutable level : int - (* The decision level at which we got a value (when not Undecided) *) + (* The decision level at which we got a value (when not Undecided) *) ; mutable undo : (lit -> unit) list - (* Functions to call if we become unbound (by backtracking) *) + (* Functions to call if we become unbound (by backtracking) *) ; watch_queue : clause Queue.t (* Clauses to notify when var becomes True *) ; neg_watch_queue : clause Queue.t (* Clauses to notify when var becomes False *) ; obj : User.t (* The object this corresponds to (for our caller and for debugging) *) @@ -137,7 +137,7 @@ module Make (User : USER) = struct ; mutable trail_lim : int list (* decision levels (len(trail) at each decision) *) ; mutable toplevel_conflict : bool ; mutable set_to_false : bool - (* we are finishing up by setting everything else to False *) + (* we are finishing up by setting everything else to False *) } let pp_reason = function @@ -567,8 +567,9 @@ module Make (User : USER) = struct let at_least_one problem ?(reason = "input fact") lits = if List.length lits = 0 then problem.toplevel_conflict <- true - else if (* if debug then log_debug "at_least_one(%s)" (string_of_lits lits); *) - List.exists (fun l -> lit_value l = True) lits + else if + (* if debug then log_debug "at_least_one(%s)" (string_of_lits lits); *) + List.exists (fun l -> lit_value l = True) lits then (* Trivially true already if any literal is True. *) () else ( @@ -589,8 +590,9 @@ module Make (User : USER) = struct | Some [] -> problem.toplevel_conflict <- true (* Everything in the list was False *) | Some unique -> - if internal_at_most_one problem unique ~learnt:false ~reason:(External reason) - = AddedFact false + if + internal_at_most_one problem unique ~learnt:false ~reason:(External reason) + = AddedFact false then problem.toplevel_conflict <- true) ;; @@ -674,7 +676,6 @@ module Make (User : USER) = struct (* The variables involved in the conflict *) let counter = ref 0 in (* The number of pending variables to check *) - (* [outcome] was caused by the literals [p_reason] all being True. Follow the causes back, adding anything decided before this level to [learnt]. When we get bored, return the literal we were processing at the time. *) diff --git a/src/0install-solver/sat.mli b/src/0install-solver/sat.mli index 883c54370dc..bfe7f947cfa 100644 --- a/src/0install-solver/sat.mli +++ b/src/0install-solver/sat.mli @@ -1,6 +1,6 @@ (* Copyright (C) 2013, Thomas Leonard * See the README file for details, or visit http://0install.net. - *) +*) (** A general purpose SAT solver. *) diff --git a/src/0install-solver/solver_core.ml b/src/0install-solver/solver_core.ml index 9e70f08a174..0df1f3bb71a 100644 --- a/src/0install-solver/solver_core.ml +++ b/src/0install-solver/solver_core.ml @@ -1,6 +1,6 @@ (* Copyright (C) 2013, Thomas Leonard * See the README file for details, or visit http://0install.net. - *) +*) (** Select a compatible set of components to run a program. *) @@ -68,9 +68,9 @@ end = struct let filter_map f m = M.merge (fun key ao _bo -> - match ao with - | Some x -> f key x - | None -> assert false) + match ao with + | Some x -> f key x + | None -> assert false) m M.empty ;; diff --git a/src/async_inotify_for_dune/async_inotify.ml b/src/async_inotify_for_dune/async_inotify.ml index 5efd719d54d..2c6f74114f4 100644 --- a/src/async_inotify_for_dune/async_inotify.ml +++ b/src/async_inotify_for_dune/async_inotify.ml @@ -87,8 +87,9 @@ let process_raw_events t events = let watch_table = t.watch_table in let ev_kinds = List.concat_map events ~f:(fun (watch, ev_kinds, trans_id, fn) -> - if Inotify.int_of_watch watch = -1 - (* queue overflow event is always reported on watch -1 *) + if + Inotify.int_of_watch watch = -1 + (* queue overflow event is always reported on watch -1 *) then List.filter_map ev_kinds ~f:(fun ev -> match ev with @@ -160,10 +161,10 @@ let pump_events t ~spawn_thread = ;; let create - ~spawn_thread - ~modify_event_selector - ~log_error - ~send_emit_events_job_to_scheduler + ~spawn_thread + ~modify_event_selector + ~log_error + ~send_emit_events_job_to_scheduler = let fd = Inotify.create () in let watch_table = Table.create (module Inotify_watch) 10 in diff --git a/src/dune_cache/local.ml b/src/dune_cache/local.ml index 4a38e900201..4dc8342d48c 100644 --- a/src/dune_cache/local.ml +++ b/src/dune_cache/local.ml @@ -73,10 +73,10 @@ module Artifacts = struct include Dune_cache_storage.Artifacts let store_metadata - ~mode - ~metadata - ~rule_digest - (artifacts : Digest.t Targets.Produced.t) + ~mode + ~metadata + ~rule_digest + (artifacts : Digest.t Targets.Produced.t) = let entries = Targets.Produced.foldi artifacts ~init:[] ~f:(fun target file_digest entries -> @@ -258,8 +258,8 @@ module Artifacts = struct ;; let create_all_or_none - (mode : Dune_cache_storage.Mode.t) - (artifacts : _ Targets.Produced.t) + (mode : Dune_cache_storage.Mode.t) + (artifacts : _ Targets.Produced.t) = let unwind = Unwind.make () in let rec mk_dir (dir : Path.Local.t) = diff --git a/src/dune_cache/shared.ml b/src/dune_cache/shared.ml index 21577b83efb..3f9a6955908 100644 --- a/src/dune_cache/shared.ml +++ b/src/dune_cache/shared.ml @@ -174,9 +174,9 @@ struct ;; let compute_target_digests_or_raise_error - ~should_remove_write_permissions_on_generated_files - ~loc - ~produced_targets + ~should_remove_write_permissions_on_generated_files + ~loc + ~produced_targets : Digest.t Targets.Produced.t = let compute_digest = @@ -268,12 +268,12 @@ struct ;; let examine_targets_and_store - ~can_go_in_shared_cache - ~loc - ~rule_digest - ~should_remove_write_permissions_on_generated_files - ~action - ~(produced_targets : unit Targets.Produced.t) + ~can_go_in_shared_cache + ~loc + ~rule_digest + ~should_remove_write_permissions_on_generated_files + ~action + ~(produced_targets : unit Targets.Produced.t) : Digest.t Targets.Produced.t Fiber.t = match config with diff --git a/src/dune_config_file/dune_config_file.ml b/src/dune_config_file/dune_config_file.ml index 6d4e8958b73..85dcf4121bb 100644 --- a/src/dune_config_file/dune_config_file.ml +++ b/src/dune_config_file/dune_config_file.ml @@ -236,18 +236,18 @@ module Dune_config = struct open To_dyn let to_dyn - { M.display - ; concurrency - ; terminal_persistence - ; sandboxing_preference - ; cache_enabled - ; cache_reproducibility_check - ; cache_storage_mode - ; action_stdout_on_success - ; action_stderr_on_success - ; project_defaults - ; experimental - } + { M.display + ; concurrency + ; terminal_persistence + ; sandboxing_preference + ; cache_enabled + ; cache_reproducibility_check + ; cache_storage_mode + ; action_stdout_on_success + ; action_stderr_on_success + ; project_defaults + ; experimental + } = Dyn.record [ "display", field Display.to_dyn display diff --git a/src/dune_digest/digest.ml b/src/dune_digest/digest.ml index 55deccac76e..9cdae45fcf9 100644 --- a/src/dune_digest/digest.ml +++ b/src/dune_digest/digest.ml @@ -116,8 +116,8 @@ let path_with_stats ~allow_dirs path (stats : Stats_for_digest.t) = let executable = Path.Permissions.test Path.Permissions.execute stats.st_perm in Dune_filesystem_stubs.Unix_error.Detailed.catch (fun path -> - let contents = Unix.readlink (Path.to_string path) in - path_with_executable_bit ~executable ~content_digest:contents) + let contents = Unix.readlink (Path.to_string path) in + path_with_executable_bit ~executable ~content_digest:contents) path |> Result.map_error ~f:(fun x -> Path_digest_error.Unix_error x) | S_REG -> diff --git a/src/dune_engine/action.ml b/src/dune_engine/action.ml index dd06e73575f..2faa3d702bd 100644 --- a/src/dune_engine/action.ml +++ b/src/dune_engine/action.ml @@ -14,12 +14,13 @@ module Make (Target : T) (String : T) (Extension : T) - (Ast : Action_intf.Ast - with type program := Program.t - with type path := Path.t - with type target := Target.t - with type string := String.t - and type ext := Extension.t) = + (Ast : + Action_intf.Ast + with type program := Program.t + with type path := Path.t + with type target := Target.t + with type string := String.t + and type ext := Extension.t) = struct include Ast @@ -334,11 +335,11 @@ module Full = struct include Monoid.Make (T) let make - ?(env = Env.empty) - ?(locks = []) - ?(can_go_in_shared_cache = !Clflags.can_go_in_shared_cache_default) - ?(sandbox = Sandbox_config.default) - action + ?(env = Env.empty) + ?(locks = []) + ?(can_go_in_shared_cache = !Clflags.can_go_in_shared_cache_default) + ?(sandbox = Sandbox_config.default) + action = { action; env; locks; can_go_in_shared_cache; sandbox } ;; diff --git a/src/dune_engine/action_exec.ml b/src/dune_engine/action_exec.ml index 77a271e8775..016859c6f8c 100644 --- a/src/dune_engine/action_exec.ml +++ b/src/dune_engine/action_exec.ml @@ -392,8 +392,8 @@ type input = } let exec - { targets; root; context; env; rule_loc; execution_parameters; action = t } - ~build_deps + { targets; root; context; env; rule_loc; execution_parameters; action = t } + ~build_deps = let ectx = let metadata = Process.create_metadata ~purpose:(Build_job targets) () in diff --git a/src/dune_engine/action_exec.mli b/src/dune_engine/action_exec.mli index d53615d41c5..2ed3b7ee7fc 100644 --- a/src/dune_engine/action_exec.mli +++ b/src/dune_engine/action_exec.mli @@ -29,7 +29,7 @@ end type input = { targets : Targets.Validated.t option (* Some Jane Street actions use [None] *) ; root : Path.t - (** [root] should be the root of the current build context, or the root + (** [root] should be the root of the current build context, or the root of the sandbox if the action is sandboxed. *) ; context : Build_context.t option ; env : Env.t diff --git a/src/dune_engine/build_config.ml b/src/dune_engine/build_config.ml index 742bf8c9fc6..a8f692a3947 100644 --- a/src/dune_engine/build_config.ml +++ b/src/dune_engine/build_config.ml @@ -27,9 +27,9 @@ module Gen_rules = struct ;; let create - ?(build_dir_only_sub_dirs = empty.build_dir_only_sub_dirs) - ?(directory_targets = empty.directory_targets) - rules + ?(build_dir_only_sub_dirs = empty.build_dir_only_sub_dirs) + ?(directory_targets = empty.directory_targets) + rules = { build_dir_only_sub_dirs; directory_targets; rules } ;; @@ -85,18 +85,18 @@ let t : t Fdecl.t = Fdecl.create Dyn.opaque let get () = Fdecl.get t let set - ~stats - ~contexts - ~promote_source - ~cache_config - ~cache_debug_flags - ~sandboxing_preference - ~rule_generator - ~implicit_default_alias - ~execution_parameters - ~source_tree - ~shared_cache - ~write_error_summary + ~stats + ~contexts + ~promote_source + ~cache_config + ~cache_debug_flags + ~sandboxing_preference + ~rule_generator + ~implicit_default_alias + ~execution_parameters + ~source_tree + ~shared_cache + ~write_error_summary = let contexts = Memo.lazy_ ~name:"Build_config.set" (fun () -> diff --git a/src/dune_engine/build_config_intf.ml b/src/dune_engine/build_config_intf.ml index 84b0faffd63..75d9b3a5fdc 100644 --- a/src/dune_engine/build_config_intf.ml +++ b/src/dune_engine/build_config_intf.ml @@ -15,11 +15,11 @@ type rules = Rules.t module Rules = struct type t = { build_dir_only_sub_dirs : Build_only_sub_dirs.t - (** Sub-directories that don't exist in the source tree but exists in + (** Sub-directories that don't exist in the source tree but exists in the build directory. This is for internal directories such as [.dune] or [.ppx]. *) ; directory_targets : Loc.t Path.Build.Map.t - (** Directories that are target of a rule. For each directory target, + (** Directories that are target of a rule. For each directory target, give the location of the rule that generates it. The keys in this map must correspond exactly to the set of directory targets that will be produces by [rules]. The values should be the locations of diff --git a/src/dune_engine/build_system.ml b/src/dune_engine/build_system.ml index 7cb8e92c139..403956c05ba 100644 --- a/src/dune_engine/build_system.ml +++ b/src/dune_engine/build_system.ml @@ -10,8 +10,8 @@ module Progress = struct } let equal - { number_of_rules_discovered; number_of_rules_executed; number_of_rules_failed } - t + { number_of_rules_discovered; number_of_rules_executed; number_of_rules_failed } + t = Int.equal number_of_rules_discovered t.number_of_rules_discovered && Int.equal number_of_rules_executed t.number_of_rules_executed @@ -248,11 +248,11 @@ end = struct let rule_digest_version = 22 let compute_rule_digest - (rule : Rule.t) - ~facts - ~action - ~sandbox_mode - ~execution_parameters + (rule : Rule.t) + ~facts + ~action + ~sandbox_mode + ~execution_parameters = let { Action.Full.action ; env @@ -325,14 +325,14 @@ end = struct ;; let execute_action_for_rule - ~rule_kind - ~rule_digest - ~action - ~facts - ~loc - ~execution_parameters - ~sandbox_mode - ~(targets : Targets.Validated.t) + ~rule_kind + ~rule_digest + ~action + ~facts + ~loc + ~execution_parameters + ~sandbox_mode + ~(targets : Targets.Validated.t) : Exec_result.t Fiber.t = let open Fiber.O in @@ -408,41 +408,41 @@ end = struct Pending_targets.remove targets; Fiber.return ()) (fun () -> - with_locks locks ~f:(fun () -> - let* action_exec_result = - let input = - { Action_exec.root - ; context (* can be derived from the root *) - ; env - ; targets = Some targets - ; rule_loc = loc - ; execution_parameters - ; action - } - in - let build_deps deps = Memo.run (build_deps deps) in - Action_exec.exec input ~build_deps - in - let* action_exec_result = Action_exec.Exec_result.ok_exn action_exec_result in - let* () = - match sandbox with - | None -> Fiber.return () - | Some sandbox -> - (* The stamp file for anonymous actions is always created outside + with_locks locks ~f:(fun () -> + let* action_exec_result = + let input = + { Action_exec.root + ; context (* can be derived from the root *) + ; env + ; targets = Some targets + ; rule_loc = loc + ; execution_parameters + ; action + } + in + let build_deps deps = Memo.run (build_deps deps) in + Action_exec.exec input ~build_deps + in + let* action_exec_result = Action_exec.Exec_result.ok_exn action_exec_result in + let* () = + match sandbox with + | None -> Fiber.return () + | Some sandbox -> + (* The stamp file for anonymous actions is always created outside the sandbox, so we can't move it. *) - let should_be_skipped = - match rule_kind with - | Normal_rule -> fun (_ : Path.Build.t) -> false - | Anonymous_action { stamp_file; _ } -> Path.Build.equal stamp_file - in - Sandbox.move_targets_to_build_dir sandbox ~should_be_skipped ~targets - in - let+ produced_targets = - maybe_async_rule_file_op (fun () -> Targets.Produced.of_validated targets) - in - match produced_targets with - | Ok produced_targets -> { Exec_result.produced_targets; action_exec_result } - | Error error -> User_error.raise ~loc (Targets.Produced.Error.message error))) + let should_be_skipped = + match rule_kind with + | Normal_rule -> fun (_ : Path.Build.t) -> false + | Anonymous_action { stamp_file; _ } -> Path.Build.equal stamp_file + in + Sandbox.move_targets_to_build_dir sandbox ~should_be_skipped ~targets + in + let+ produced_targets = + maybe_async_rule_file_op (fun () -> Targets.Produced.of_validated targets) + in + match produced_targets with + | Ok produced_targets -> { Exec_result.produced_targets; action_exec_result } + | Error error -> User_error.raise ~loc (Targets.Produced.Error.message error))) ;; let promote_targets ~rule_mode ~targets ~promote_source = @@ -675,7 +675,7 @@ end = struct (* Returns the action's stdout or the empty string if [capture_stdout = false]. *) let execute_action_generic_stage2_impl - { Anonymous_action.action = act; deps; capture_stdout; digest } + { Anonymous_action.action = act; deps; capture_stdout; digest } = let target = let dir = @@ -725,9 +725,9 @@ end = struct let action_digest_version = 2 let execute_action_generic - ~observing_facts - (act : Rule.Anonymous_action.t) - ~capture_stdout + ~observing_facts + (act : Rule.Anonymous_action.t) + ~capture_stdout = (* We memoize the execution of anonymous actions, both via the persistent mechanism for not re-running build rules between invocations of [dune @@ -920,8 +920,9 @@ end = struct >>= Memo.parallel_map ~f:(fun (loc, definition) -> Memo.push_stack_frame (fun () -> - Action_builder.evaluate_and_collect_facts (dep_on_alias_definition definition) - >>| snd) + Action_builder.evaluate_and_collect_facts + (dep_on_alias_definition definition) + >>| snd) ~human_readable_description:(fun () -> Alias.describe alias ~loc)) in Dep.Facts.group_paths_as_fact_files l diff --git a/src/dune_engine/context_name.ml b/src/dune_engine/context_name.ml index 5f54e4c0ecd..63d81b0ef1c 100644 --- a/src/dune_engine/context_name.ml +++ b/src/dune_engine/context_name.ml @@ -16,11 +16,12 @@ include ( let description = "context name" let of_string_opt name = - if name = "" - || String.is_prefix name ~prefix:"." - || name = "log" - || String.contains name '/' - || String.contains name '\\' + if + name = "" + || String.is_prefix name ~prefix:"." + || name = "log" + || String.contains name '/' + || String.contains name '\\' then None else Some name ;; diff --git a/src/dune_engine/execution_parameters.ml b/src/dune_engine/execution_parameters.ml index f8a6c9c84f8..0b3f2794310 100644 --- a/src/dune_engine/execution_parameters.ml +++ b/src/dune_engine/execution_parameters.ml @@ -58,15 +58,15 @@ type t = } let equal - { action_stdout_on_success - ; action_stderr_on_success - ; action_stdout_limit - ; action_stderr_limit - ; expand_aliases_in_sandbox - ; workspace_root_to_build_path_prefix_map - ; should_remove_write_permissions_on_generated_files - } - t + { action_stdout_on_success + ; action_stderr_on_success + ; action_stdout_limit + ; action_stderr_limit + ; expand_aliases_in_sandbox + ; workspace_root_to_build_path_prefix_map + ; should_remove_write_permissions_on_generated_files + } + t = Action_output_on_success.equal action_stdout_on_success t.action_stdout_on_success && Action_output_on_success.equal action_stderr_on_success t.action_stderr_on_success @@ -82,14 +82,14 @@ let equal ;; let hash - { action_stdout_on_success - ; action_stderr_on_success - ; action_stdout_limit - ; action_stderr_limit - ; expand_aliases_in_sandbox - ; workspace_root_to_build_path_prefix_map - ; should_remove_write_permissions_on_generated_files - } + { action_stdout_on_success + ; action_stderr_on_success + ; action_stdout_limit + ; action_stderr_limit + ; expand_aliases_in_sandbox + ; workspace_root_to_build_path_prefix_map + ; should_remove_write_permissions_on_generated_files + } = Poly.hash ( Action_output_on_success.hash action_stdout_on_success @@ -102,14 +102,14 @@ let hash ;; let to_dyn - { action_stdout_on_success - ; action_stderr_on_success - ; action_stdout_limit - ; action_stderr_limit - ; expand_aliases_in_sandbox - ; workspace_root_to_build_path_prefix_map - ; should_remove_write_permissions_on_generated_files - } + { action_stdout_on_success + ; action_stderr_on_success + ; action_stdout_limit + ; action_stderr_limit + ; expand_aliases_in_sandbox + ; workspace_root_to_build_path_prefix_map + ; should_remove_write_permissions_on_generated_files + } = Dyn.Record [ "action_stdout_on_success", Action_output_on_success.to_dyn action_stdout_on_success diff --git a/src/dune_engine/fs_memo.ml b/src/dune_engine/fs_memo.ml index b8ff87a831a..166ee424b55 100644 --- a/src/dune_engine/fs_memo.ml +++ b/src/dune_engine/fs_memo.ml @@ -113,8 +113,8 @@ end = struct "fs_memo_for_watching_directly" ~input:(module Path.Outside_build_dir) (fun accessed_path -> - watch_or_record_path ~accessed_path ~path_to_watch:accessed_path; - Memo.return ()) + watch_or_record_path ~accessed_path ~path_to_watch:accessed_path; + Memo.return ()) ;; let memo_for_watching_via_parent = @@ -122,13 +122,13 @@ end = struct "fs_memo_for_watching_via_parent" ~input:(module Path.Outside_build_dir) (fun accessed_path -> - let path_to_watch = - Option.value - (Path.Outside_build_dir.parent accessed_path) - ~default:accessed_path - in - watch_or_record_path ~accessed_path ~path_to_watch; - Memo.return ()) + let path_to_watch = + Option.value + (Path.Outside_build_dir.parent accessed_path) + ~default:accessed_path + in + watch_or_record_path ~accessed_path ~path_to_watch; + Memo.return ()) ;; let watch ~try_to_watch_via_parent path = diff --git a/src/dune_engine/load_rules.ml b/src/dune_engine/load_rules.ml index 22791a82a94..dc7abc49084 100644 --- a/src/dune_engine/load_rules.ml +++ b/src/dune_engine/load_rules.ml @@ -187,9 +187,9 @@ let report_rule_conflict fn (rule' : Rule.t) (rule : Rule.t) = ;; let remove_old_artifacts - ~dir - ~(rules_here : Loaded.rules_here) - ~(subdirs_to_keep : Subdir_set.t) + ~dir + ~(rules_here : Loaded.rules_here) + ~(subdirs_to_keep : Subdir_set.t) = match Path.Untracked.readdir_unsorted_with_kinds (Path.build dir) with | Error _ -> () @@ -538,8 +538,8 @@ end = struct ;; let make_rules_gen_result - ~of_ - { Gen_rules.Rules.build_dir_only_sub_dirs; directory_targets; rules } + ~of_ + { Gen_rules.Rules.build_dir_only_sub_dirs; directory_targets; rules } = check_all_directory_targets_are_descendant ~of_ directory_targets; check_all_sub_dirs_rule_dirs_are_descendant ~of_ build_dir_only_sub_dirs; @@ -570,7 +570,8 @@ end = struct ;; let call_rules_generator - ({ Dir_triage.Build_directory.dir; context_name; context_type = _; sub_dir } as d) + ({ Dir_triage.Build_directory.dir; context_name; context_type = _; sub_dir } as + d) = let (module RG : Rule_generator) = (Build_config.get ()).rule_generator in let sub_dir_components = Path.Source.explode sub_dir in @@ -703,10 +704,10 @@ end = struct ;; let descendants_to_keep - { Dir_triage.Build_directory.dir; context_name = _; context_type; sub_dir } - (build_dir_only_sub_dirs : Subdir_set.t) - ~source_dirs - rules_produced + { Dir_triage.Build_directory.dir; context_name = _; context_type; sub_dir } + (build_dir_only_sub_dirs : Subdir_set.t) + ~source_dirs + rules_produced = let* allowed_by_parent = match context_type, Path.Source.to_string sub_dir with @@ -762,12 +763,13 @@ end = struct ;; let validate_directory_targets ~dir ~real_directory_targets ~directory_targets = - if not - (Path.Build.Map.equal real_directory_targets directory_targets ~equal:(fun _ _ -> - (* The locations should match if the declaration knows which + if + not + (Path.Build.Map.equal real_directory_targets directory_targets ~equal:(fun _ _ -> + (* The locations should match if the declaration knows which rule will generate the directory, but it's not necessary as the rule's actual location has higher priority. *) - true)) + true)) then ( let mismatched_directories = let error message loc = @@ -791,7 +793,8 @@ end = struct ;; let load_build_directory_exn - ({ Dir_triage.Build_directory.dir; context_name; context_type; sub_dir } as build_dir) + ({ Dir_triage.Build_directory.dir; context_name; context_type; sub_dir } as + build_dir) = (* Load all the rules *) Gen_rules.gen_rules build_dir @@ -804,8 +807,9 @@ end = struct in Path.Build.Map.iteri directory_targets ~f:(fun dir_target loc -> let name = Path.Build.basename dir_target in - if Path.Build.equal (Path.Build.parent_exn dir_target) dir - && Subdir_set.mem build_dir_only_sub_dirs name + if + Path.Build.equal (Path.Build.parent_exn dir_target) dir + && Subdir_set.mem build_dir_only_sub_dirs name then report_rule_internal_dir_conflict name loc); let* rules_produced = Memo.Lazy.force rules in let rules = diff --git a/src/dune_engine/process.ml b/src/dune_engine/process.ml index 67e1aaf8b5a..bebd665ecfe 100644 --- a/src/dune_engine/process.ml +++ b/src/dune_engine/process.ml @@ -199,12 +199,12 @@ let default_metadata = ;; let create_metadata - ?loc - ?(annots = default_metadata.annots) - ?name - ?(categories = default_metadata.categories) - ?(purpose = Internal_job) - () + ?loc + ?(annots = default_metadata.annots) + ?name + ?(categories = default_metadata.categories) + ?(purpose = Internal_job) + () = { loc; annots; name; categories; purpose } ;; @@ -217,10 +217,10 @@ let io_to_redirection_path (kind : Io.kind) = ;; let command_line_enclosers - ~dir - ~(stdout_to : Io.output Io.t) - ~(stderr_to : Io.output Io.t) - ~(stdin_from : Io.input Io.t) + ~dir + ~(stdout_to : Io.output Io.t) + ~(stderr_to : Io.output Io.t) + ~(stdin_from : Io.input Io.t) = let quote fn = String.quote_for_shell (Path.to_string fn) in let prefix, suffix = @@ -433,11 +433,11 @@ end = struct let pp_ok = progname_and_purpose ~tag:Ok let pp_error - ~prog - ~purpose - ~has_unexpected_stdout - ~has_unexpected_stderr - ~(error : Exit_status.error) + ~prog + ~purpose + ~has_unexpected_stdout + ~has_unexpected_stderr + ~(error : Exit_status.error) = let open Pp.O in let msg = @@ -591,20 +591,21 @@ end = struct ;; let non_verbose - t - ~(verbosity : Display.t) - ~metadata - ~output - ~prog - ~command_line - ~dir - ~has_unexpected_stdout - ~has_unexpected_stderr + t + ~(verbosity : Display.t) + ~metadata + ~output + ~prog + ~command_line + ~dir + ~has_unexpected_stdout + ~has_unexpected_stderr = let output = parse_output output in let show_command = !Clflags.always_show_command_line - || (* We want to show command lines in the CI, but not when running inside + || + (* We want to show command lines in the CI, but not when running inside dune. Otherwise tests would yield different result whether they are executed locally or in the CI. *) (Execution_env.inside_ci && not Execution_env.inside_dune) @@ -746,17 +747,17 @@ module Result = struct ;; let make - ({ stdout_on_success - ; stderr_on_success - ; stdout_limit - ; stderr_limit - ; stdout - ; stderr - ; _ - } : - process) - (process_info : Proc.Process_info.t) - fail_mode + ({ stdout_on_success + ; stderr_on_success + ; stdout_limit + ; stderr_limit + ; stdout + ; stderr + ; _ + } : + process) + (process_info : Proc.Process_info.t) + fail_mode = let stdout = Out.make stdout ~on_success:stdout_on_success ~limit:stdout_limit in let stderr = Out.make stderr ~on_success:stderr_on_success ~limit:stderr_limit in @@ -777,17 +778,17 @@ module Result = struct end let report_process_finished - stats - ~metadata - ~dir - ~prog - ~pid - ~args - ~started_at - ~exit_status - ~stdout - ~stderr - (times : Proc.Times.t) + stats + ~metadata + ~dir + ~prog + ~pid + ~args + ~started_at + ~exit_status + ~stdout + ~stderr + (times : Proc.Times.t) = let common = let name = @@ -855,14 +856,14 @@ let await { response_file; pid; _ } = ;; let spawn - ?dir - ?(env = Env.initial) - ~(stdout : _ Io.t) - ~(stderr : _ Io.t) - ~(stdin : _ Io.t) - ~prog - ~args - () + ?dir + ?(env = Env.initial) + ~(stdout : _ Io.t) + ~(stderr : _ Io.t) + ~(stdin : _ Io.t) + ~prog + ~args + () = let stdout_on_success = Io.output_on_success stdout and stderr_on_success = Io.output_on_success stderr in @@ -966,16 +967,16 @@ let spawn ;; let run_internal - ?dir - ~(display : Display.t) - ?(stdout_to = Io.stdout) - ?(stderr_to = Io.stderr) - ?(stdin_from = Io.null In) - ?env - ?(metadata = default_metadata) - fail_mode - prog - args + ?dir + ~(display : Display.t) + ?(stdout_to = Io.stdout) + ?(stderr_to = Io.stderr) + ?(stdin_from = Io.null In) + ?env + ?(metadata = default_metadata) + fail_mode + prog + args = Scheduler.with_job_slot (fun _cancel (config : Scheduler.Config.t) -> let dir = @@ -1103,16 +1104,16 @@ let run ?dir ~display ?stdout_to ?stderr_to ?stdin_from ?env ?metadata fail_mode ;; let run_with_times - ?dir - ~display - ?stdout_to - ?stderr_to - ?stdin_from - ?env - ?metadata - fail_mode - prog - args + ?dir + ~display + ?stdout_to + ?stderr_to + ?stdin_from + ?env + ?metadata + fail_mode + prog + args = let+ code, times = run_internal @@ -1131,16 +1132,16 @@ let run_with_times ;; let run_capture_gen - ?dir - ~display - ?stderr_to - ?stdin_from - ?env - ?metadata - fail_mode - prog - args - ~f + ?dir + ~display + ?stderr_to + ?stdin_from + ?env + ?metadata + fail_mode + prog + args + ~f = let fn = Temp.create File ~prefix:"dune" ~suffix:"output" in let+ run = @@ -1168,15 +1169,15 @@ let run_capture_lines = run_capture_gen ~f:Stdune.Io.lines_of_file let run_capture_zero_separated = run_capture_gen ~f:Stdune.Io.zero_strings_of_file let run_capture_line - ?dir - ~display - ?stderr_to - ?stdin_from - ?env - ?metadata - fail_mode - prog - args + ?dir + ~display + ?stderr_to + ?stdin_from + ?env + ?metadata + fail_mode + prog + args = run_capture_gen ?dir diff --git a/src/dune_engine/process.mli b/src/dune_engine/process.mli index 9bd74ea394a..19deccc06c1 100644 --- a/src/dune_engine/process.mli +++ b/src/dune_engine/process.mli @@ -68,7 +68,7 @@ type metadata = { loc : Loc.t option ; annots : User_message.Annots.t ; name : string option - (** name when emitting stats. defaults to the basename of the executable *) + (** name when emitting stats. defaults to the basename of the executable *) ; categories : string list (** additional categories when emitting stats *) ; purpose : purpose } diff --git a/src/dune_engine/reflection.ml b/src/dune_engine/reflection.ml index 437fd3d8d01..daea2ced8bc 100644 --- a/src/dune_engine/reflection.ml +++ b/src/dune_engine/reflection.ml @@ -24,18 +24,18 @@ end = struct "expand-alias" ~input:(module Alias) (fun alias -> - let* l = - Load_rules.get_alias_definition alias - >>= Memo.parallel_map ~f:(fun (loc, definition) -> - Memo.push_stack_frame - (fun () -> - Action_builder.evaluate_and_collect_deps - (Build_system.dep_on_alias_definition definition) - >>| snd) - ~human_readable_description:(fun () -> Alias.describe alias ~loc)) - in - let deps = List.fold_left l ~init:Dep.Set.empty ~f:Dep.Set.union in - Expand.deps deps) + let* l = + Load_rules.get_alias_definition alias + >>= Memo.parallel_map ~f:(fun (loc, definition) -> + Memo.push_stack_frame + (fun () -> + Action_builder.evaluate_and_collect_deps + (Build_system.dep_on_alias_definition definition) + >>| snd) + ~human_readable_description:(fun () -> Alias.describe alias ~loc)) + in + let deps = List.fold_left l ~init:Dep.Set.empty ~f:Dep.Set.union in + Expand.deps deps) in Memo.exec memo ;; @@ -61,15 +61,15 @@ let evaluate_rule = "evaluate-rule" ~input:(module Non_evaluated_rule) (fun rule -> - let* action, deps = Action_builder.evaluate_and_collect_deps rule.action in - let* expanded_deps = Expand.deps deps in - Memo.return - { Rule.id = rule.id - ; deps - ; expanded_deps - ; targets = rule.targets - ; action = action.action - }) + let* action, deps = Action_builder.evaluate_and_collect_deps rule.action in + let* expanded_deps = Expand.deps deps in + Memo.return + { Rule.id = rule.id + ; deps + ; expanded_deps + ; targets = rule.targets + ; action = action.action + }) in Memo.exec memo ;; diff --git a/src/dune_engine/rule.mli b/src/dune_engine/rule.mli index 376f21e0c3d..7b22a2c4da9 100644 --- a/src/dune_engine/rule.mli +++ b/src/dune_engine/rule.mli @@ -86,7 +86,7 @@ module Anonymous_action : sig { action : Action.Full.t ; loc : Loc.t ; dir : Path.Build.t - (** Directory the action is attached to. This is the directory where + (** Directory the action is attached to. This is the directory where the outcome of the action will be cached. *) ; alias : Alias.Name.t option (** For better error messages *) } diff --git a/src/dune_engine/rule_cache.ml b/src/dune_engine/rule_cache.ml index fec4ffec41a..ea2aaaa35b1 100644 --- a/src/dune_engine/rule_cache.ml +++ b/src/dune_engine/rule_cache.ml @@ -218,12 +218,12 @@ module Shared = struct ;; let examine_targets_and_store - ~can_go_in_shared_cache - ~loc - ~rule_digest - ~should_remove_write_permissions_on_generated_files - ~action - ~produced_targets + ~can_go_in_shared_cache + ~loc + ~rule_digest + ~should_remove_write_permissions_on_generated_files + ~action + ~produced_targets = let config = Build_config.get () in let module Shared_cache = (val config.shared_cache) in diff --git a/src/dune_engine/scheduler.ml b/src/dune_engine/scheduler.ml index 256fffe5f20..09b2d37b516 100644 --- a/src/dune_engine/scheduler.ml +++ b/src/dune_engine/scheduler.ml @@ -88,8 +88,8 @@ end = struct (* 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 -> - Lazy.force block_signals; - Thread.create f x + Lazy.force block_signals; + Thread.create f x ;; let spawn f = @@ -1227,11 +1227,11 @@ module Run = struct ;; let go - (config : Config.t) - ?timeout_seconds - ?(file_watcher = No_watcher) - ~(on_event : Config.t -> Handler.Event.t -> unit) - run + (config : Config.t) + ?timeout_seconds + ?(file_watcher = No_watcher) + ~(on_event : Config.t -> Handler.Event.t -> unit) + run = let events = Event_queue.create config.stats in let file_watcher = @@ -1260,14 +1260,14 @@ module Run = struct let sleep = Alarm_clock.sleep (Lazy.force t.alarm_clock) ~seconds:timeout in Fiber.fork_and_join_unit (fun () -> - let+ res = Alarm_clock.await sleep in - match res with - | `Finished -> Event_queue.send_shutdown t.events Timeout - | `Cancelled -> ()) + let+ res = Alarm_clock.await sleep in + match res with + | `Finished -> Event_queue.send_shutdown t.events Timeout + | `Cancelled -> ()) (fun () -> - Fiber.finalize run ~finally:(fun () -> - Alarm_clock.cancel (Lazy.force t.alarm_clock) sleep; - Fiber.return ())) + Fiber.finalize run ~finally:(fun () -> + Alarm_clock.cancel (Lazy.force t.alarm_clock) sleep; + Fiber.return ())) in match Run_once.run_and_cleanup t run with | Ok a -> Result.Ok a @@ -1318,16 +1318,16 @@ let wait_for_process_with_timeout t pid waiter ~timeout_seconds ~is_process_grou let sleep = Alarm_clock.sleep (Lazy.force t.alarm_clock) ~seconds:timeout_seconds in Fiber.fork_and_join_unit (fun () -> - let+ res = Alarm_clock.await sleep in - if res = `Finished && Process_watcher.is_running t.process_watcher pid - then - if is_process_group_leader - then kill_process_group pid Sys.sigkill - else Unix.kill (Pid.to_int pid) Sys.sigkill) + let+ res = Alarm_clock.await sleep in + if res = `Finished && Process_watcher.is_running t.process_watcher pid + then + if is_process_group_leader + then kill_process_group pid Sys.sigkill + else Unix.kill (Pid.to_int pid) Sys.sigkill) (fun () -> - let+ res = waiter t pid in - Alarm_clock.cancel (Lazy.force t.alarm_clock) sleep; - res)) + let+ res = waiter t pid in + Alarm_clock.cancel (Lazy.force t.alarm_clock) sleep; + res)) ;; let wait_for_build_process ?timeout_seconds ?(is_process_group_leader = false) pid = diff --git a/src/dune_engine/target_promotion.ml b/src/dune_engine/target_promotion.ml index ebe09cbaa2a..54e2a17b9bf 100644 --- a/src/dune_engine/target_promotion.ml +++ b/src/dune_engine/target_promotion.ml @@ -51,11 +51,11 @@ end let files_in_source_tree_to_delete () = To_delete.get_db () let promote_target_if_not_up_to_date - ~src - ~src_digest - ~dst - ~promote_source - ~promote_until_clean + ~src + ~src_digest + ~dst + ~promote_source + ~promote_until_clean = let open Fiber.O in (* It is OK to use [Fs_cache.Untracked.file_digest] here because below we use @@ -175,8 +175,8 @@ let promote ~(targets : _ Targets.Produced.t) ~(promote : Rule.Promote.t) ~promo (match Unix_error.Detailed.catch (fun () -> - Path.unlink_no_err dst_dir; - Path.mkdir_p dst_dir) + Path.unlink_no_err dst_dir; + Path.mkdir_p dst_dir) () with | Ok () -> () diff --git a/src/dune_file_watcher/dune_file_watcher.ml b/src/dune_file_watcher/dune_file_watcher.ml index fab71da5d46..de2a5aa9af8 100644 --- a/src/dune_file_watcher/dune_file_watcher.ml +++ b/src/dune_file_watcher/dune_file_watcher.ml @@ -154,7 +154,7 @@ type kind = type t = { kind : kind ; sync_table : (string, Sync_id.t) Table.t - (* Pending fs sync operations indexed by the special sync filename. *) + (* Pending fs sync operations indexed by the special sync filename. *) } module Re = Dune_re @@ -170,8 +170,8 @@ module For_tests = struct end let process_inotify_event - (event : Async_inotify_for_dune.Async_inotify.Event.t) - should_exclude + (event : Async_inotify_for_dune.Async_inotify.Event.t) + should_exclude : Event.t list = let create_event_unless_excluded ~kind ~path = @@ -575,15 +575,15 @@ let create_fsevents ?(latency = 0.2) ~(scheduler : Scheduler.t) ~should_exclude ~paths:[ Path.build (Lazy.force Fs_sync.special_dir_path) ] scheduler (fun event localized_path -> - let path = Fsevents.Event.path event in - if not (Fs_sync.is_special_file_fsevents localized_path) - then None - else ( - match Fsevents.Event.action event with - | Remove -> None - | Rename | Unknown | Create | Modify -> - Option.map (Fs_sync.consume_event sync_table path) ~f:(fun id -> - Event.Sync id))) + let path = Fsevents.Event.path event in + if not (Fs_sync.is_special_file_fsevents localized_path) + then None + else ( + match Fsevents.Event.action event with + | Remove -> None + | Rename | Unknown | Create | Modify -> + Option.map (Fs_sync.consume_event sync_table path) ~f:(fun id -> + Event.Sync id))) in let on_event = fsevents_standard_event ~should_exclude in let source = diff --git a/src/dune_file_watcher/dune_file_watcher.mli b/src/dune_file_watcher/dune_file_watcher.mli index dde617407a5..c7a6cdf0c1e 100644 --- a/src/dune_file_watcher/dune_file_watcher.mli +++ b/src/dune_file_watcher/dune_file_watcher.mli @@ -50,10 +50,10 @@ module Scheduler : sig (** Hook into the fiber scheduler. *) type t = { spawn_thread : (unit -> unit) -> unit - (** We spawn threads through this function in case the scheduler wants + (** We spawn threads through this function in case the scheduler wants to block signals *) ; thread_safe_send_emit_events_job : (unit -> Event.t list) -> unit - (** Send some events to the scheduler. The events are sent in the form + (** Send some events to the scheduler. The events are sent in the form of a thunk to be executed on the scheduler thread, so that we can do some bookkeeping that needs to happen there. *) } diff --git a/src/dune_findlib/config.ml b/src/dune_findlib/config.ml index a8e826fcb2b..1ec09c76add 100644 --- a/src/dune_findlib/config.ml +++ b/src/dune_findlib/config.ml @@ -65,8 +65,10 @@ let to_dyn { config; ocamlpath = _; toolchain; which = _ } = ;; let ocamlpath_sep = - if Sys.cygwin then (* because that's what ocamlfind expects *) - ';' else Bin.path_sep + if Sys.cygwin + then (* because that's what ocamlfind expects *) + ';' + else Bin.path_sep ;; let ocamlpath_var = "OCAMLPATH" diff --git a/src/dune_lang/action.ml b/src/dune_lang/action.ml index 8914ae8d996..4a6571bed93 100644 --- a/src/dune_lang/action.ml +++ b/src/dune_lang/action.ml @@ -115,9 +115,9 @@ module Env_update = struct let map t ~f = { t with value = f t.value } let equal - value_equal - { op; var; value } - { op = other_op; var = other_var; value = other_value } + value_equal + { op; var; value } + { op = other_op; var = other_var; value = other_value } = Op.equal op other_op && Ordering.is_eq (Env.Var.compare var other_var) diff --git a/src/dune_lang/bindings.ml b/src/dune_lang/bindings.ml index d6c39fe7c0f..06580e913ab 100644 --- a/src/dune_lang/bindings.ml +++ b/src/dune_lang/bindings.ml @@ -73,9 +73,9 @@ let decode elem = let encode encode bindings = Dune_sexp.List (List.map bindings ~f:(function - | Unnamed a -> encode a - | Named (name, bindings) -> - Dune_sexp.List (Dune_sexp.atom (":" ^ name) :: List.map ~f:encode bindings))) + | Unnamed a -> encode a + | Named (name, bindings) -> + Dune_sexp.List (Dune_sexp.atom (":" ^ name) :: List.map ~f:encode bindings))) ;; let var_names t = @@ -87,6 +87,6 @@ let var_names t = let to_pform_map t = Pform.Map.of_list_exn (List.filter_map t ~f:(function - | Unnamed _ -> None - | Named (name, l) -> Some (Pform.Var (User_var name), l))) + | Unnamed _ -> None + | Named (name, l) -> Some (Pform.Var (User_var name), l))) ;; diff --git a/src/dune_lang/package.ml b/src/dune_lang/package.ml index f4351eb3dda..0491f0bedc1 100644 --- a/src/dune_lang/package.ml +++ b/src/dune_lang/package.ml @@ -83,24 +83,24 @@ let set_inside_opam_dir t ~dir = { t with opam_file = Name.file t.id.name ~dir } let set_version_and_info t ~version ~info = { t with version; info } let encode - (name : Name.t) - { id = _ - ; loc = _ - ; has_opam_file = _ - ; synopsis - ; description - ; depends - ; conflicts - ; depopts - ; info - ; version - ; tags - ; deprecated_package_names - ; sites - ; allow_empty - ; opam_file = _ - ; original_opam_file = _ - } + (name : Name.t) + { id = _ + ; loc = _ + ; has_opam_file = _ + ; synopsis + ; description + ; depends + ; conflicts + ; depopts + ; info + ; version + ; tags + ; deprecated_package_names + ; sites + ; allow_empty + ; opam_file = _ + ; original_opam_file = _ + } = let open Encoder in let fields = @@ -206,23 +206,23 @@ let dyn_of_opam_file = ;; let to_dyn - { id - ; version - ; synopsis - ; description - ; depends - ; conflicts - ; depopts - ; info - ; has_opam_file - ; tags - ; loc = _ - ; deprecated_package_names - ; sites - ; allow_empty - ; opam_file = _ - ; original_opam_file = _ - } + { id + ; version + ; synopsis + ; description + ; depends + ; conflicts + ; depopts + ; info + ; has_opam_file + ; tags + ; loc = _ + ; deprecated_package_names + ; sites + ; allow_empty + ; opam_file = _ + ; original_opam_file = _ + } = let open Dyn in record @@ -249,22 +249,22 @@ let allow_empty t = t.allow_empty let map_depends t ~f = { t with depends = f t.depends } let create - ~name - ~loc - ~version - ~conflicts - ~depends - ~depopts - ~info - ~has_opam_file - ~dir - ~sites - ~allow_empty - ~synopsis - ~description - ~tags - ~original_opam_file - ~deprecated_package_names + ~name + ~loc + ~version + ~conflicts + ~depends + ~depopts + ~info + ~has_opam_file + ~dir + ~sites + ~allow_empty + ~synopsis + ~description + ~tags + ~original_opam_file + ~deprecated_package_names = let id = { Id.name; dir } in { id diff --git a/src/dune_lang/package_info.ml b/src/dune_lang/package_info.ml index cfcce1b6eb8..eae891e3e53 100644 --- a/src/dune_lang/package_info.ml +++ b/src/dune_lang/package_info.ml @@ -72,7 +72,7 @@ let to_dyn { source; license; authors; homepage; bug_reports; documentation; mai ;; let encode_fields - { source; authors; license; homepage; documentation; bug_reports; maintainers } + { source; authors; license; homepage; documentation; bug_reports; maintainers } = let open Encoder in record_fields diff --git a/src/dune_lang/slang.ml b/src/dune_lang/slang.ml index d11901d4e2f..e5daea14841 100644 --- a/src/dune_lang/slang.ml +++ b/src/dune_lang/slang.ml @@ -215,8 +215,8 @@ let rec simplify = function (* only quote strings when not quoting them would be an error *) not (List.for_all parts ~f:(function - | `Pform _ -> true - | `Text s -> Atom.is_valid s)) + | `Pform _ -> true + | `Text s -> Atom.is_valid s)) in let combined_sw = String_with_vars.make ~quoted loc parts in Literal combined_sw) diff --git a/src/dune_lang/string_with_vars.ml b/src/dune_lang/string_with_vars.ml index 68ccd0bfce6..c0ea35afd8e 100644 --- a/src/dune_lang/string_with_vars.ml +++ b/src/dune_lang/string_with_vars.ml @@ -135,10 +135,8 @@ module Mode = struct type (_, _) t = | Single : (Value.Deferred_concat.t, Value.t) t | Many : (Value.Deferred_concat.t list, Value.t list) t - | At_least_one - : ( Value.Deferred_concat.t * Value.Deferred_concat.t list - , Value.t * Value.t list ) - t + | At_least_one : + (Value.Deferred_concat.t * Value.Deferred_concat.t list, Value.t * Value.t list) t let string : type deferred_concat value. (deferred_concat, value) t -> string -> deferred_concat @@ -341,16 +339,16 @@ module Make_expander (A : Applicative) : Expander with type 'a app := 'a A.t = s let+ chunks = A.all (List.map t.parts ~f:(function - | Text s -> A.return (Ok (Value.Deferred_concat.singleton (Value.String s))) - | Error (_, msg) -> - (* The [let+ () = A.return () in ...] is to delay the error until + | Text s -> A.return (Ok (Value.Deferred_concat.singleton (Value.String s))) + | Error (_, msg) -> + (* The [let+ () = A.return () in ...] is to delay the error until the evaluation of the applicative *) - let+ () = A.return () in - raise (User_error.E msg) - | Pform (source, p) -> - let+ v = f ~source p in - Result.map v ~f:(fun v -> - Value.Deferred_concat.concat_values v ~sep:inner_sep))) + let+ () = A.return () in + raise (User_error.E msg) + | Pform (source, p) -> + let+ v = f ~source p in + Result.map v ~f:(fun v -> + Value.Deferred_concat.concat_values v ~sep:inner_sep))) in Result.map (Result.List.all chunks) ~f:(fun chunks -> Value.Deferred_concat.concat chunks ~sep:None |> Mode.deferred_concat mode) diff --git a/src/dune_lang/string_with_vars.mli b/src/dune_lang/string_with_vars.mli index f99506d19b6..e18ed38aa23 100644 --- a/src/dune_lang/string_with_vars.mli +++ b/src/dune_lang/string_with_vars.mli @@ -68,10 +68,9 @@ module Mode : sig (** Expansion must produce a single value *) | Many : (Value.Deferred_concat.t list, Value.t list) t (** Expansion may produce any number of values *) - | At_least_one - : ( Value.Deferred_concat.t * Value.Deferred_concat.t list - , Value.t * Value.t list ) - t (** Expansion may produce 1 or more values *) + | At_least_one : + (Value.Deferred_concat.t * Value.Deferred_concat.t list, Value.t * Value.t list) t + (** Expansion may produce 1 or more values *) end type yes_no_unknown = diff --git a/src/dune_lang/visibility.ml b/src/dune_lang/visibility.ml index 8d80521c07f..1c26a5e334b 100644 --- a/src/dune_lang/visibility.ml +++ b/src/dune_lang/visibility.ml @@ -20,14 +20,13 @@ let encode = let decode = let open Dune_sexp.Decoder in - plain_string (fun ~loc -> - function - | "public" -> Public - | "private" -> Private - | _ -> - User_error.raise - ~loc - [ Pp.text "Not a valid visibility. Valid visibility is public or private" ]) + plain_string (fun ~loc -> function + | "public" -> Public + | "private" -> Private + | _ -> + User_error.raise + ~loc + [ Pp.text "Not a valid visibility. Valid visibility is public or private" ]) ;; module Map = struct diff --git a/src/dune_lang/warning.ml b/src/dune_lang/warning.ml index 8706e883b54..ed9c64211dc 100644 --- a/src/dune_lang/warning.ml +++ b/src/dune_lang/warning.ml @@ -22,7 +22,7 @@ type t = { name : Name.t ; since : Syntax.Version.t (* The version where this warning was introduced. *) ; default : Syntax.Version.t -> Config.Toggle.t - (* Decide the version where this warning should be enabled. This is + (* Decide the version where this warning should be enabled. This is needed because some warnings were introduced before this module existed *) } diff --git a/src/dune_pkg/dependency_formula.ml b/src/dune_pkg/dependency_formula.ml index 055e1153b00..c45cee01800 100644 --- a/src/dune_pkg/dependency_formula.ml +++ b/src/dune_pkg/dependency_formula.ml @@ -12,8 +12,9 @@ let remove_packages (v : OpamTypes.filtered_formula) pkgs = OpamFormula.map_up_formula (function | Atom (name, _condition) as a -> - if let name = Package_name.of_opam_package_name name in - Package_name.Set.mem pkgs name + if + let name = Package_name.of_opam_package_name name in + Package_name.Set.mem pkgs name then Empty else a | x -> x) @@ -26,8 +27,8 @@ let any_package_name (v : OpamTypes.filtered_formula) = try OpamFormula.iter (fun (name, _condition) -> - let name = Package_name.of_opam_package_name name in - raise_notrace (Found name)) + let name = Package_name.of_opam_package_name name in + raise_notrace (Found name)) v; None with diff --git a/src/dune_pkg/fetch.ml b/src/dune_pkg/fetch.ml index 28f7a45e245..19fc83e08b4 100644 --- a/src/dune_pkg/fetch.ml +++ b/src/dune_pkg/fetch.ml @@ -188,8 +188,8 @@ let fetch_curl ~unpack:unpack_flag ~checksum ~target (url : OpamUrl.t) = let fetch_git rev_store ~target ~url:(url_loc, url) = OpamUrl.resolve url ~loc:url_loc rev_store >>= (function - | Error _ as e -> Fiber.return e - | Ok r -> OpamUrl.fetch_revision url ~loc:url_loc r rev_store) + | Error _ as e -> Fiber.return e + | Ok r -> OpamUrl.fetch_revision url ~loc:url_loc r rev_store) >>= function | Error msg -> Fiber.return @@ Error (Unavailable (Some msg)) | Ok at_rev -> @@ -240,18 +240,18 @@ let fetch ~unpack ~checksum ~target ~url:(url_loc, url) = Dune_stats.finish event; Fiber.return ()) (fun () -> - match url.backend with - | `git -> - let* rev_store = Rev_store.get in - fetch_git rev_store ~target ~url:(url_loc, url) - | `http -> fetch_curl ~unpack ~checksum ~target url - | `rsync -> - if not unpack - then - Code_error.raise "fetch_local: unpack is not set" [ "url", OpamUrl.to_dyn url ]; - fetch_local ~checksum ~target (url, url_loc) - | `hg -> unsupported_backend "mercurial" - | `darcs -> unsupported_backend "darcs") + match url.backend with + | `git -> + let* rev_store = Rev_store.get in + fetch_git rev_store ~target ~url:(url_loc, url) + | `http -> fetch_curl ~unpack ~checksum ~target url + | `rsync -> + if not unpack + then + Code_error.raise "fetch_local: unpack is not set" [ "url", OpamUrl.to_dyn url ]; + fetch_local ~checksum ~target (url, url_loc) + | `hg -> unsupported_backend "mercurial" + | `darcs -> unsupported_backend "darcs") ;; let fetch_without_checksum ~unpack ~target ~url = diff --git a/src/dune_pkg/fiber_cache.ml b/src/dune_pkg/fiber_cache.ml index b08b44f22c6..0785c930fee 100644 --- a/src/dune_pkg/fiber_cache.ml +++ b/src/dune_pkg/fiber_cache.ml @@ -4,7 +4,7 @@ type ('k, 'v) t = { (* The cache stores results so that if an exception was raised while computing a value, concurrent accesses to the cache can find out. *) table : ('k, ('v, Exn_with_backtrace.t list) result Fiber.Ivar.t) Table.t - (* This module is stored so it can be reused to create a table from the cache. *) + (* This module is stored so it can be reused to create a table from the cache. *) ; key_module : (module Table.Key with type t = 'k) } diff --git a/src/dune_pkg/local_package.ml b/src/dune_pkg/local_package.ml index 6bfc71cd798..6f3cf09dfb9 100644 --- a/src/dune_pkg/local_package.ml +++ b/src/dune_pkg/local_package.ml @@ -83,7 +83,15 @@ module For_solver = struct end let for_solver - { name; version = _; dependencies; conflicts; conflict_class; loc = _; depopts; pins } + { name + ; version = _ + ; dependencies + ; conflicts + ; conflict_class + ; loc = _ + ; depopts + ; pins + } = { For_solver.name; dependencies; conflicts; conflict_class; depopts; pins } ;; diff --git a/src/dune_pkg/lock_dir.ml b/src/dune_pkg/lock_dir.ml index f5708288c4d..d3b71741e93 100644 --- a/src/dune_pkg/lock_dir.ml +++ b/src/dune_pkg/lock_dir.ml @@ -214,13 +214,13 @@ module Pkg = struct ;; let encode - { build_command - ; install_command - ; depends - ; depexts - ; info = { Pkg_info.name = _; extra_sources; version; dev; source } - ; exported_env - } + { build_command + ; install_command + ; depends + ; depexts + ; info = { Pkg_info.name = _; extra_sources; version; dev; source } + ; exported_env + } = let open Encoder in record_fields @@ -303,8 +303,14 @@ let remove_locs t = ;; let equal - { version; dependency_hash; packages; ocaml; repos; expanded_solver_variable_bindings } - t + { version + ; dependency_hash + ; packages + ; ocaml + ; repos + ; expanded_solver_variable_bindings + } + t = Syntax.Version.equal version t.version && Option.equal @@ -320,7 +326,13 @@ let equal ;; let to_dyn - { version; dependency_hash; packages; ocaml; repos; expanded_solver_variable_bindings } + { version + ; dependency_hash + ; packages + ; ocaml + ; repos + ; expanded_solver_variable_bindings + } = Dyn.record [ "version", Syntax.Version.to_dyn version @@ -353,8 +365,9 @@ let validate_packages packages = List.filter_map dependant_package.depends ~f:(fun (loc, dependency) -> (* CR-someday rgrinberg: do we need the dune check? aren't we supposed to filter these upfront? *) - if Package_name.Map.mem packages dependency - || Package_name.equal dependency Dune_dep.name + if + Package_name.Map.mem packages dependency + || Package_name.equal dependency Dune_dep.name then None else Some { dependant_package; dependency; loc })) in @@ -364,11 +377,11 @@ let validate_packages packages = ;; let create_latest_version - packages - ~local_packages - ~ocaml - ~repos - ~expanded_solver_variable_bindings + packages + ~local_packages + ~ocaml + ~repos + ~expanded_solver_variable_bindings = (match validate_packages packages with | Ok () -> () @@ -420,13 +433,13 @@ module Metadata = Dune_sexp.Versioned_file.Make (Unit) let () = Metadata.Lang.register Dune_lang.Pkg.syntax () let encode_metadata - { version - ; dependency_hash - ; ocaml - ; repos - ; packages = _ - ; expanded_solver_variable_bindings - } + { version + ; dependency_hash + ; ocaml + ; repos + ; packages = _ + ; expanded_solver_variable_bindings + } = let open Encoder in let base = @@ -585,9 +598,9 @@ module Write_disk = struct type t = unit -> unit let prepare - ~lock_dir_path:lock_dir_path_src - ~(files : File_entry.t Package_name.Map.Multi.t) - lock_dir + ~lock_dir_path:lock_dir_path_src + ~(files : File_entry.t Package_name.Map.Multi.t) + lock_dir = let lock_dir_hidden_src = (* The original lockdir path with the lockdir renamed to begin with a ".". *) diff --git a/src/dune_pkg/lock_dir.mli b/src/dune_pkg/lock_dir.mli index 2398d43431f..d42db52fc82 100644 --- a/src/dune_pkg/lock_dir.mli +++ b/src/dune_pkg/lock_dir.mli @@ -49,13 +49,13 @@ type t = private { version : Syntax.Version.t ; dependency_hash : (Loc.t * Local_package.Dependency_hash.t) option ; packages : Pkg.t Package_name.Map.t - (** It's guaranteed that this map will contain an entry for all dependencies + (** It's guaranteed that this map will contain an entry for all dependencies of all packages in this map. That is, the set of packages is closed under the "depends on" relationship between packages. *) ; ocaml : (Loc.t * Package_name.t) option ; repos : Repositories.t ; expanded_solver_variable_bindings : Solver_stats.Expanded_variable_bindings.t - (** Stores the solver variables that were evaluated while solving + (** Stores the solver variables that were evaluated while solving dependencies. Can be used to determine if a lockdir is compatible with a particular system. *) } diff --git a/src/dune_pkg/mount.ml b/src/dune_pkg/mount.ml index 6b42da733c2..b681f9e96d1 100644 --- a/src/dune_pkg/mount.ml +++ b/src/dune_pkg/mount.ml @@ -18,8 +18,8 @@ let of_opam_url loc url = 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) + | Error _ as e -> Fiber.return e + | Ok s -> OpamUrl.fetch_revision url ~loc s rev_store) >>| User_error.ok_exn in Git rev @@ -58,9 +58,10 @@ let stat t path = | Some parent -> let files = Rev_store.At_rev.directory_entries ~recursive:false rev parent in let basename = Path.Local.basename path in - if Rev_store.File.Set.exists files ~f:(fun file -> - let path = Rev_store.File.path file in - String.equal basename (Path.Local.basename path)) + if + Rev_store.File.Set.exists files ~f:(fun file -> + let path = Rev_store.File.path file in + String.equal basename (Path.Local.basename path)) then `File else `Absent_or_unrecognized)) ;; diff --git a/src/dune_pkg/opam_dyn.ml b/src/dune_pkg/opam_dyn.ml index bbf7c5373df..741a80a2568 100644 --- a/src/dune_pkg/opam_dyn.ml +++ b/src/dune_pkg/opam_dyn.ml @@ -43,8 +43,8 @@ let rec filter (filter_ : OpamTypes.filter) = ;; let filter_or_constraint - atom_to_dyn - (filter_or_constraint_ : _ OpamTypes.filter_or_constraint) + atom_to_dyn + (filter_or_constraint_ : _ OpamTypes.filter_or_constraint) = match filter_or_constraint_ with | Filter filter_ -> Dyn.variant "Filter" [ filter filter_ ] diff --git a/src/dune_pkg/opam_file.ml b/src/dune_pkg/opam_file.ml index c28ec969749..d3ef0c2bc6c 100644 --- a/src/dune_pkg/opam_file.ml +++ b/src/dune_pkg/opam_file.ml @@ -4,8 +4,8 @@ open OpamParserTypes.FullPos type t = opamfile let loc_of_opam_pos - ({ filename; start = start_line, start_column; stop = stop_line, stop_column } : - OpamParserTypes.FullPos.pos) + ({ filename; start = start_line, start_column; stop = stop_line, stop_column } : + OpamParserTypes.FullPos.pos) = let start = { Lexing.pos_fname = filename diff --git a/src/dune_pkg/opam_repo.ml b/src/dune_pkg/opam_repo.ml index be12a18b0de..b43163ac57a 100644 --- a/src/dune_pkg/opam_repo.ml +++ b/src/dune_pkg/opam_repo.ml @@ -106,8 +106,8 @@ let of_git_repo loc url = 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) + | Error _ as e -> Fiber.return e + | Ok s -> OpamUrl.fetch_revision url ~loc s rev_store) >>| User_error.ok_exn in let serializable = diff --git a/src/dune_pkg/opam_solver.ml b/src/dune_pkg/opam_solver.ml index d2d8ffd640f..fa160a52af9 100644 --- a/src/dune_pkg/opam_solver.ml +++ b/src/dune_pkg/opam_solver.ml @@ -83,13 +83,13 @@ module Context_for_dune = struct } let create - ~pinned_packages - ~solver_env - ~repos - ~local_packages - ~version_preference - ~stats_updater - ~constraints + ~pinned_packages + ~solver_env + ~repos + ~local_packages + ~version_preference + ~stats_updater + ~constraints = let candidates_cache = Fiber_cache.create (module Package_name) in let constraints = @@ -238,10 +238,10 @@ module Context_for_dune = struct let filtered_formula = OpamFormula.fold_left (fun additional_formulae (pkg, _) -> - let name = Package_name.of_opam_package_name pkg in - match Package_name.Map.find t.constraints name with - | None -> additional_formulae - | Some additional -> additional :: additional_formulae) + let name = Package_name.of_opam_package_name pkg in + match Package_name.Map.find t.constraints name with + | None -> additional_formulae + | Some additional -> additional :: additional_formulae) [] filtered_formula |> List.fold_left ~init:filtered_formula ~f:(fun additional acc -> @@ -443,10 +443,10 @@ let partial_eval_filter = function ;; let opam_commands_to_actions - get_solver_var - loc - package - (commands : OpamTypes.command list) + get_solver_var + loc + package + (commands : OpamTypes.command list) = List.filter_map commands ~f:(fun (args, filter) -> let filter = Option.map filter ~f:(simplify_filter get_solver_var) in @@ -551,12 +551,12 @@ let resolve_depopts ~resolve depopts = ;; let opam_package_to_lock_file_pkg - solver_env - stats_updater - version_by_package_name - opam_package - ~pinned_package_names - ~(candidates_cache : (Package_name.t, Context_for_dune.candidates) Table.t) + solver_env + stats_updater + version_by_package_name + opam_package + ~pinned_package_names + ~(candidates_cache : (Package_name.t, Context_for_dune.candidates) Table.t) = let name = Package_name.of_opam_package_name (OpamPackage.name opam_package) in let version = @@ -710,12 +710,12 @@ let solve_package_list packages ~context = instead. *) Solver.solve context packages) >>| (function - | Ok (Ok res) -> Ok res - | Ok (Error e) -> Error (`Diagnostics e) - | Error [] -> assert false - | Error (exn :: _) -> - (* CR-rgrinberg: this needs to be handled right *) - Error (`Exn exn.exn)) + | Ok (Ok res) -> Ok res + | Ok (Error e) -> Error (`Diagnostics e) + | Error [] -> assert false + | Error (exn :: _) -> + (* CR-rgrinberg: this needs to be handled right *) + Error (`Exn exn.exn)) >>= function | Ok packages -> Fiber.return @@ Ok (Solver.packages_of_result packages) | Error (`Diagnostics e) -> @@ -823,12 +823,12 @@ let reject_unreachable_packages = ;; let solve_lock_dir - solver_env - version_preference - repos - ~local_packages - ~pins:pinned_packages - ~constraints + solver_env + version_preference + repos + ~local_packages + ~pins:pinned_packages + ~constraints = let pinned_package_names = Package_name.Set.of_keys pinned_packages in let stats_updater = Solver_stats.Updater.init () in diff --git a/src/dune_pkg/package_universe.ml b/src/dune_pkg/package_universe.ml index a93e4483c57..6b76956f9d1 100644 --- a/src/dune_pkg/package_universe.ml +++ b/src/dune_pkg/package_universe.ml @@ -87,8 +87,8 @@ let all_non_local_dependencies_of_local_packages t = ;; let check_for_unnecessary_packges_in_lock_dir - lock_dir - all_non_local_dependencies_of_local_packages + lock_dir + all_non_local_dependencies_of_local_packages = let unneeded_packages_in_lock_dir = let locked_transitive_closure_of_local_package_dependencies = @@ -198,9 +198,10 @@ let validate_dependency_hash local_packages ~saved_dependency_hash = (Package_name.to_string any_non_local_dependency_name) ] | Some (loc, lock_dir_dependency_hash), Some non_local_dependency_hash -> - if Local_package.Dependency_hash.equal - lock_dir_dependency_hash - non_local_dependency_hash + if + Local_package.Dependency_hash.equal + lock_dir_dependency_hash + non_local_dependency_hash then () else User_error.raise diff --git a/src/dune_pkg/pin_stanza.ml b/src/dune_pkg/pin_stanza.ml index 4d7a387ff7a..09ce39673bb 100644 --- a/src/dune_pkg/pin_stanza.ml +++ b/src/dune_pkg/pin_stanza.ml @@ -290,9 +290,10 @@ let resolve (t : DB.t) ~(scan_project : Scan_project.t) assigned := Package_name.Map.add_exn !assigned package.name (package, stack); `Continue | Some (assigned, prefix) -> - if Stack.is_prefix stack ~prefix - || (OpamUrl.equal (snd assigned.url) (snd package.url) - && Package_version.equal package.version assigned.version) + if + Stack.is_prefix stack ~prefix + || (OpamUrl.equal (snd assigned.url) (snd package.url) + && Package_version.equal package.version assigned.version) then `Skip else (* CR-rgrinberg: we need to cancel all the other fibers *) diff --git a/src/dune_pkg/resolve_opam_formula.ml b/src/dune_pkg/resolve_opam_formula.ml index e4d00d6baea..b712f22b0a0 100644 --- a/src/dune_pkg/resolve_opam_formula.ml +++ b/src/dune_pkg/resolve_opam_formula.ml @@ -6,11 +6,11 @@ let apply_filter env ~with_test (opam_filtered_formula : OpamTypes.filtered_form = OpamFilter.gen_filter_formula (OpamFormula.partial_eval (function - | OpamTypes.Filter flt -> - `Formula (Atom (OpamTypes.Filter (OpamFilter.partial_eval env flt))) - | Constraint (relop, filter) -> - let filter = OpamFilter.partial_eval env filter in - `Formula (Atom (Constraint (relop, filter))))) + | OpamTypes.Filter flt -> + `Formula (Atom (OpamTypes.Filter (OpamFilter.partial_eval env flt))) + | Constraint (relop, filter) -> + let filter = OpamFilter.partial_eval env filter in + `Formula (Atom (Constraint (relop, filter))))) opam_filtered_formula |> OpamFilter.filter_deps ~build:true @@ -169,8 +169,8 @@ let override_post post_value env var = (* Check that a package version satisfies the version constraint associated with a package dependency in an opam file. *) let package_version_satisfies_opam_version_constraint_opt - package_version - opam_version_constraint_opt + package_version + opam_version_constraint_opt = match opam_version_constraint_opt with | None -> true @@ -192,9 +192,10 @@ let formula_to_package_names_allow_missing version_by_package_name opam_formula let package_name = Package_name.of_opam_package_name opam_package_name in Package_name.Map.find version_by_package_name package_name |> Option.bind ~f:(fun version_in_solution -> - if package_version_satisfies_opam_version_constraint_opt - version_in_solution - version_constraint_opt + if + package_version_satisfies_opam_version_constraint_opt + version_in_solution + version_constraint_opt then Some package_name else None))) ;; diff --git a/src/dune_pkg/rev_store.ml b/src/dune_pkg/rev_store.ml index 2a0f1a39e28..793405e3ec4 100644 --- a/src/dune_pkg/rev_store.ml +++ b/src/dune_pkg/rev_store.ml @@ -19,10 +19,11 @@ module Object = struct type resolved = t let of_sha1 s = - if String.length s = 40 - && String.for_all s ~f:(function - | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true - | _ -> false) + if + String.length s = 40 + && String.for_all s ~f:(function + | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true + | _ -> false) then Some (Sha1 (String.lowercase_ascii s)) else None ;; @@ -92,40 +93,40 @@ let with_flock lock_path ~f = let+ () = Fiber.return () in Unix.close fd) (fun () -> - attempt_to_lock flock Flock.Exclusive ~max_retries - >>= function - | Ok `Success -> - Fiber.finalize - (fun () -> - Dune_util.Global_lock.write_pid fd; - f ()) - ~finally:(fun () -> - let+ () = Fiber.return () in - Path.unlink_no_err lock_path; - match Flock.unlock flock with - | Ok () -> () - | Error ue -> - Unix_error.Detailed.create ue ~syscall:"flock" ~arg:"unlock" - |> Unix_error.Detailed.raise) - | Ok `Failure -> - let pid = Io.read_file lock_path in - User_error.raise - ~hints: - [ Pp.textf - "Another dune instance (pid %s) has locked the revision store. If this \ - is happening in error, make sure to terminate that instance and re-run \ - the command." - pid - ] - [ Pp.textf "Couldn't acquire revision store lock after %d attempts" max_retries - ] - | Error error -> - User_error.raise - [ Pp.textf - "Failed to get a lock for the revision store at %s: %s" - (Path.to_string_maybe_quoted lock_path) - (Unix.error_message error) - ]) + attempt_to_lock flock Flock.Exclusive ~max_retries + >>= function + | Ok `Success -> + Fiber.finalize + (fun () -> + Dune_util.Global_lock.write_pid fd; + f ()) + ~finally:(fun () -> + let+ () = Fiber.return () in + Path.unlink_no_err lock_path; + match Flock.unlock flock with + | Ok () -> () + | Error ue -> + Unix_error.Detailed.create ue ~syscall:"flock" ~arg:"unlock" + |> Unix_error.Detailed.raise) + | Ok `Failure -> + let pid = Io.read_file lock_path in + User_error.raise + ~hints: + [ Pp.textf + "Another dune instance (pid %s) has locked the revision store. If this \ + is happening in error, make sure to terminate that instance and re-run \ + the command." + pid + ] + [ Pp.textf "Couldn't acquire revision store lock after %d attempts" max_retries + ] + | Error error -> + User_error.raise + [ Pp.textf + "Failed to get a lock for the revision store at %s: %s" + (Path.to_string_maybe_quoted lock_path) + (Unix.error_message error) + ]) ;; let failure_mode = Process.Failure_mode.Return @@ -675,8 +676,9 @@ module At_rev = struct let file_path = File.path file in (* [directory_entries "foo"] shouldn't return "foo" as an entry, but "foo" is indeed a descendant of itself. So we filter it manually. *) - if (not (Path.Local.equal file_path path)) - && Path.Local.is_descendant file_path ~of_:path + if + (not (Path.Local.equal file_path path)) + && Path.Local.is_descendant file_path ~of_:path then Some file else None) |> File.Set.of_list diff --git a/src/dune_pkg/source.ml b/src/dune_pkg/source.ml index 26e9326be05..6e552e02fe1 100644 --- a/src/dune_pkg/source.ml +++ b/src/dune_pkg/source.ml @@ -12,14 +12,14 @@ let remove_locs { url = _loc, url; checksum } = ;; let equal - { url = loc, url; checksum } - { url = other_loc, other_url; checksum = other_checksum } + { url = loc, url; checksum } + { url = other_loc, other_url; checksum = other_checksum } = Loc.equal loc other_loc && OpamUrl.equal url other_url && Option.equal (fun (loc, checksum) (other_loc, other_checksum) -> - Loc.equal loc other_loc && Checksum.equal checksum other_checksum) + Loc.equal loc other_loc && Checksum.equal checksum other_checksum) checksum other_checksum ;; @@ -55,17 +55,18 @@ let fetch_and_hash_archive_cached = ;; let compute_missing_checksum - ({ url = url_loc, url; checksum } as fetch) - package_name - ~pinned + ({ url = url_loc, url; checksum } as fetch) + package_name + ~pinned = let open Fiber.O in match checksum with | Some _ -> Fiber.return fetch | None when OpamUrl.is_local url || OpamUrl.is_version_control url -> Fiber.return fetch | None -> - if not pinned - (* No point in warning this about pinned packages. The user explicitly + if + not pinned + (* No point in warning this about pinned packages. The user explicitly asked for the pins *) then User_message.print diff --git a/src/dune_pkg_outdated/dune_pkg_outdated.ml b/src/dune_pkg_outdated/dune_pkg_outdated.ml index ec8d4f22354..b6a6f6d67b8 100644 --- a/src/dune_pkg_outdated/dune_pkg_outdated.ml +++ b/src/dune_pkg_outdated/dune_pkg_outdated.ml @@ -82,9 +82,9 @@ let explain_results_to_user results ~transitive ~lock_dir_path = ;; let better_candidate - ~repos - ~(local_packages : Dune_pkg.Local_package.t Package_name.Map.t) - (pkg : Lock_dir.Pkg.t) + ~repos + ~(local_packages : Dune_pkg.Local_package.t Package_name.Map.t) + (pkg : Lock_dir.Pkg.t) = let open Fiber.O in let pkg_name = pkg.info.name |> Package_name.to_string |> OpamPackage.Name.of_string in @@ -182,10 +182,10 @@ module For_tests = struct let package_is_best_candidate = Package_is_best_candidate let better_candidate - ~is_immediate_dep_of_local_package - ~name - ~newer_version - ~outdated_version + ~is_immediate_dep_of_local_package + ~name + ~newer_version + ~outdated_version = Better_candidate { is_immediate_dep_of_local_package diff --git a/src/dune_rpc_impl/server.ml b/src/dune_rpc_impl/server.ml index a3387699251..517a8dfe9c2 100644 --- a/src/dune_rpc_impl/server.ml +++ b/src/dune_rpc_impl/server.ml @@ -71,34 +71,34 @@ module Run = struct let* () = Fiber.Ivar.fill t.server_ivar server in Fiber.fork_and_join_unit (fun () -> - let* sessions = Csexp_rpc.Server.serve server in - let () = - with_registry - @@ fun () -> - let (`Caller_should_write { Registry.File.path; contents }) = - let registry_config = Registry.Config.create (Lazy.force Dune_util.xdg) in - let dune = - let pid = Unix.getpid () in - let where = - match t.where with - | `Ip (host, port) -> `Ip (host, port) - | `Unix a -> - `Unix - (if Filename.is_relative a - then Filename.concat (Sys.getcwd ()) a - else a) - in - Registry.Dune.create ~where ~root:t.root ~pid - in - Registry.Config.register registry_config dune - in - let (_ : Fpath.mkdir_p_result) = Fpath.mkdir_p (Filename.dirname path) in - Io.String_path.write_file path contents; - cleanup_registry := Some path; - at_exit run_cleanup_registry - in - let* () = Server.serve sessions t.stats t.handler in - Fiber.Pool.close t.pool) + let* sessions = Csexp_rpc.Server.serve server in + let () = + with_registry + @@ fun () -> + let (`Caller_should_write { Registry.File.path; contents }) = + let registry_config = Registry.Config.create (Lazy.force Dune_util.xdg) in + let dune = + let pid = Unix.getpid () in + let where = + match t.where with + | `Ip (host, port) -> `Ip (host, port) + | `Unix a -> + `Unix + (if Filename.is_relative a + then Filename.concat (Sys.getcwd ()) a + else a) + in + Registry.Dune.create ~where ~root:t.root ~pid + in + Registry.Config.register registry_config dune + in + let (_ : Fpath.mkdir_p_result) = Fpath.mkdir_p (Filename.dirname path) in + Io.String_path.write_file path contents; + cleanup_registry := Some path; + at_exit run_cleanup_registry + in + let* () = Server.serve sessions t.stats t.handler in + Fiber.Pool.close t.pool) (fun () -> Fiber.Pool.run t.pool) in Fiber.finalize (with_print_errors run) ~finally:(fun () -> diff --git a/src/dune_rpc_server/dune_rpc_server.ml b/src/dune_rpc_server/dune_rpc_server.ml index 3896e7ccf17..676d3f8c5ee 100644 --- a/src/dune_rpc_server/dune_rpc_server.ml +++ b/src/dune_rpc_server/dune_rpc_server.ml @@ -100,7 +100,7 @@ module Session = struct ; mutable state : 'a state ; (* TODO these should be cancelled when the connection closes *) pending : (Dune_rpc_private.Id.t, Response.t Fiber.Ivar.t) Table.t - (** Pending requests sent to the client. When a response is + (** Pending requests sent to the client. When a response is received, the ivar for the response will be filled. *) ; name : string } @@ -177,8 +177,8 @@ module Session = struct ;; let to_dyn - f - { id; state; close; queries = _; send = _; pool = _; pending = _; menu; name } + f + { id; state; close; queries = _; send = _; pool = _; pending = _; menu; name } = let open Dyn in record @@ -503,11 +503,11 @@ module H = struct ;; let create - ?(on_terminate = fun _ -> Fiber.return ()) - ~on_init - ?(on_upgrade = fun _ _ -> Fiber.return ()) - ~version - () + ?(on_terminate = fun _ -> Fiber.return ()) + ~on_init + ?(on_upgrade = fun _ _ -> Fiber.return ()) + ~version + () = { builder = V.Builder.create (); on_init; on_terminate; version; on_upgrade } ;; @@ -630,8 +630,8 @@ let new_session (Server handler) stats ~name ~queries ~send = Fiber.fork_and_join_unit (fun () -> Fiber.Pool.run session.pool) (fun () -> - let* () = H.handle handler stats session in - Session.Stage1.close session) + let* () = H.handle handler stats session in + Session.Stage1.close session) end ;; diff --git a/src/dune_rules/action_unexpanded.ml b/src/dune_rules/action_unexpanded.ml index e5cb07d5ccf..d0a742cfe4d 100644 --- a/src/dune_rules/action_unexpanded.ml +++ b/src/dune_rules/action_unexpanded.ml @@ -612,13 +612,13 @@ let expand_no_targets t ~loc ~chdir ~deps:deps_written_by_user ~expander ~what = ;; let expand - t - ~loc - ~chdir - ~deps:deps_written_by_user - ~targets_dir - ~targets:targets_written_by_user - ~expander + t + ~loc + ~chdir + ~deps:deps_written_by_user + ~targets_dir + ~targets:targets_written_by_user + ~expander = let open Action_builder.O in let deps_builder, expander, sandbox = diff --git a/src/dune_rules/artifact_substitution.ml b/src/dune_rules/artifact_substitution.ml index 28158f4abe7..4280422fffb 100644 --- a/src/dune_rules/artifact_substitution.ml +++ b/src/dune_rules/artifact_substitution.ml @@ -220,10 +220,10 @@ let eval t ~(conf : Conf.t) = | Hardcoded_ocaml_path -> conf.hardcoded_ocaml_path >>| (function - | Relocatable _ -> "relocatable" - | Hardcoded l -> - let l = List.map l ~f:Path.to_absolute_filename in - "hardcoded\000" ^ String.concat ~sep:"\000" l) + | Relocatable _ -> "relocatable" + | Hardcoded l -> + let l = List.map l ~f:Path.to_absolute_filename in + "hardcoded\000" ^ String.concat ~sep:"\000" l) |> Memo.run ;; @@ -288,12 +288,13 @@ let decode s = in let len = String.length s in match - if len > max_len - || len < 4 - || s.[0] <> '%' - || s.[1] <> '%' - || s.[len - 2] <> '%' - || s.[len - 1] <> '%' + if + len > max_len + || len < 4 + || s.[0] <> '%' + || s.[1] <> '%' + || s.[len - 2] <> '%' + || s.[len - 1] <> '%' then fail (); let dune_placeholder, len', rest = match String.split (String.sub s ~pos:2 ~len:(len - 4)) ~on:':' with @@ -689,11 +690,11 @@ let copy_file ~conf ?chmod ?(delete_dst_if_it_is_a_directory = false) ~src ~dst in Fiber.finalize (fun () -> - let open Fiber.O in - Path.parent dst |> Option.iter ~f:Path.mkdir_p; - let* has_subst = copy_file_non_atomic ~conf ?chmod ~src ~dst:temp_file () in - let+ () = Conf.run_sign_hook conf ~has_subst temp_file in - replace_if_different ~delete_dst_if_it_is_a_directory ~src:temp_file ~dst) + let open Fiber.O in + Path.parent dst |> Option.iter ~f:Path.mkdir_p; + let* has_subst = copy_file_non_atomic ~conf ?chmod ~src ~dst:temp_file () in + let+ () = Conf.run_sign_hook conf ~has_subst temp_file in + replace_if_different ~delete_dst_if_it_is_a_directory ~src:temp_file ~dst) ~finally:(fun () -> Path.unlink_no_err temp_file; Fiber.return ()) diff --git a/src/dune_rules/buildable_rules.ml b/src/dune_rules/buildable_rules.ml index 178b8c9dc99..193d9fcb5e6 100644 --- a/src/dune_rules/buildable_rules.ml +++ b/src/dune_rules/buildable_rules.ml @@ -63,17 +63,17 @@ type kind = } let modules_rules - ~preprocess - ~preprocessor_deps - ~lint - ~empty_module_interface_if_absent - sctx - expander - ~dir - scope - modules - ~lib_name - ~empty_intf_modules + ~preprocess + ~preprocessor_deps + ~lint + ~empty_module_interface_if_absent + sctx + expander + ~dir + scope + modules + ~lib_name + ~empty_intf_modules = let* pp = let instrumentation_backend = Lib.DB.instrumentation_backend (Scope.libs scope) in diff --git a/src/dune_rules/cinaps.ml b/src/dune_rules/cinaps.ml index 5d6ad7223ab..7d5c9e9af73 100644 --- a/src/dune_rules/cinaps.ml +++ b/src/dune_rules/cinaps.ml @@ -82,10 +82,11 @@ let gen_rules sctx t ~dir ~scope = Source_tree.files_of (Path.Build.drop_build_context_exn dir) >>| Path.Source.Set.to_list >>| List.filter_map ~f:(fun p -> - if Predicate_lang.Glob.test - t.files - (Path.Source.basename p) - ~standard:Predicate_lang.true_ + if + Predicate_lang.Glob.test + t.files + (Path.Source.basename p) + ~standard:Predicate_lang.true_ then Some (Path.Build.append_source (Super_context.context sctx |> Context.build_dir) p) diff --git a/src/dune_rules/compilation_context.ml b/src/dune_rules/compilation_context.ml index e75d2649bb6..91d4ca677ae 100644 --- a/src/dune_rules/compilation_context.ml +++ b/src/dune_rules/compilation_context.ml @@ -129,24 +129,24 @@ let dep_graphs t = t.modules.dep_graphs let ocaml t = t.ocaml let create - ~super_context - ~scope - ~obj_dir - ~modules - ~flags - ~requires_compile - ~requires_link - ?(preprocessing = Pp_spec.dummy) - ~opaque - ?stdlib - ~js_of_ocaml - ~package - ~melange_package_name - ?vimpl - ?modes - ?bin_annot - ?loc - () + ~super_context + ~scope + ~obj_dir + ~modules + ~flags + ~requires_compile + ~requires_link + ?(preprocessing = Pp_spec.dummy) + ~opaque + ?stdlib + ~js_of_ocaml + ~package + ~melange_package_name + ?vimpl + ?modes + ?bin_annot + ?loc + () = let project = Scope.project scope in let context = Super_context.context super_context in @@ -154,8 +154,9 @@ let create let direct_requires, hidden_requires = if Dune_project.implicit_transitive_deps project then Memo.Lazy.force requires_link, Resolve.Memo.return [] - else if Version.supports_hidden_includes ocaml.version - && Dune_project.dune_version project >= (3, 17) + else if + Version.supports_hidden_includes ocaml.version + && Dune_project.dune_version project >= (3, 17) then ( let requires_hidden = let open Resolve.Memo.O in diff --git a/src/dune_rules/context.ml b/src/dune_rules/context.ml index 70f924355a1..f949c00bf5c 100644 --- a/src/dune_rules/context.ml +++ b/src/dune_rules/context.ml @@ -130,20 +130,20 @@ module Builder = struct ;; let set_workspace_base - t - { Workspace.Context.Common.targets = _ - ; name - ; host_context = _ - ; profile - ; env = _ - ; toolchain - ; paths - ; loc = _ - ; fdo_target_exe - ; dynamically_linked_foreign_archives - ; instrument_with - ; merlin - } + t + { Workspace.Context.Common.targets = _ + ; name + ; host_context = _ + ; profile + ; env = _ + ; toolchain + ; paths + ; loc = _ + ; fdo_target_exe + ; dynamically_linked_foreign_archives + ; instrument_with + ; merlin + } = let env = let env = Global.env () in @@ -406,9 +406,9 @@ let create (builder : Builder.t) ~(kind : Kind.t) = "base environment for context %S" (Context_name.to_string builder.name)) (fun () -> - let+ current_env = builder.env - and+ pkg_env = Pkg_rules.exported_env builder.name in - Env_path.extend_env_concat_path current_env pkg_env) + let+ current_env = builder.env + and+ pkg_env = Pkg_rules.exported_env builder.name in + Env_path.extend_env_concat_path current_env pkg_env) |> Memo.Lazy.force in { builder with env } @@ -427,33 +427,33 @@ let create (builder : Builder.t) ~(kind : Kind.t) = prog (Context_name.to_string builder.name)) (fun () -> - which prog - >>= function - | Some p -> Memo.return (Some p) - | None -> Which.which ~path:builder.path prog) + which prog + >>= function + | Some p -> Memo.return (Some p) + | None -> Which.which ~path:builder.path prog) in let ocamlpath = Memo.lazy_ ~human_readable_description:(fun () -> Pp.textf "loading OCAMLPATH for context %S" (Context_name.to_string builder.name)) (fun () -> - match kind with - | Lock _ -> Pkg_rules.ocamlpath builder.name - | Default | Opam _ -> - let+ ocamlpath = builder.env >>| Findlib_config.ocamlpath_of_env in - Kind.ocamlpath kind ~ocamlpath ~findlib_toolchain:builder.findlib_toolchain) + match kind with + | Lock _ -> Pkg_rules.ocamlpath builder.name + | Default | Opam _ -> + let+ ocamlpath = builder.env >>| Findlib_config.ocamlpath_of_env in + Kind.ocamlpath kind ~ocamlpath ~findlib_toolchain:builder.findlib_toolchain) in let findlib = Memo.lazy_ ~human_readable_description:(fun () -> Pp.textf "loading findlib for context %S" (Context_name.to_string builder.name)) (fun () -> - let ocamlpath = Memo.Lazy.force ocamlpath in - let* env = builder.env in - let findlib_toolchain = - Option.map builder.findlib_toolchain ~f:Context_name.to_string - in - Findlib_config.discover_from_env ~env ~which ~ocamlpath ~findlib_toolchain) + let ocamlpath = Memo.Lazy.force ocamlpath in + let* env = builder.env in + let findlib_toolchain = + Option.map builder.findlib_toolchain ~f:Context_name.to_string + in + Findlib_config.discover_from_env ~env ~which ~ocamlpath ~findlib_toolchain) in let ocaml_and_build_env_kind = Memo.Lazy.create @@ -463,34 +463,34 @@ let create (builder : Builder.t) ~(kind : Kind.t) = "loading the OCaml compiler for context %S" (Context_name.to_string builder.name)) (fun () -> - let+ ocaml, env = - let* findlib = Memo.Lazy.force findlib - and* env = builder.env in - let toolchain kind = - let+ toolchain = - Ocaml_toolchain.of_env_with_findlib - builder.name - env - findlib - ~which:which_outside_lockdir - in - toolchain, kind - in - match kind with - | Default -> toolchain `Default - | Opam _ -> toolchain `Opam - | Lock _ -> - Pkg_rules.ocaml_toolchain builder.name - >>= (function - | None -> toolchain `Lock - | Some toolchain -> - let+ toolchain, _ = Action_builder.evaluate_and_collect_facts toolchain in - toolchain, `Default) - in - Ocaml_toolchain.register_response_file_support ocaml; - if Option.is_some builder.fdo_target_exe - then Ocaml_toolchain.check_fdo_support ocaml builder.name; - ocaml, env) + let+ ocaml, env = + let* findlib = Memo.Lazy.force findlib + and* env = builder.env in + let toolchain kind = + let+ toolchain = + Ocaml_toolchain.of_env_with_findlib + builder.name + env + findlib + ~which:which_outside_lockdir + in + toolchain, kind + in + match kind with + | Default -> toolchain `Default + | Opam _ -> toolchain `Opam + | Lock _ -> + Pkg_rules.ocaml_toolchain builder.name + >>= (function + | None -> toolchain `Lock + | Some toolchain -> + let+ toolchain, _ = Action_builder.evaluate_and_collect_facts toolchain in + toolchain, `Default) + in + Ocaml_toolchain.register_response_file_support ocaml; + if Option.is_some builder.fdo_target_exe + then Ocaml_toolchain.check_fdo_support ocaml builder.name; + ocaml, env) in let default_ocamlpath = Memo.Lazy.create ~name:"default_ocamlpath" ~cutoff:(List.equal Path.equal) (fun () -> @@ -516,9 +516,9 @@ let create (builder : Builder.t) ~(kind : Kind.t) = "creating installed environment for %S" (Context_name.to_string builder.name)) (fun () -> - let* findlib = Memo.Lazy.force findlib in - let+ env = builder.env in - make_installed_env env builder.name findlib builder.env_nodes builder.profile) + let* findlib = Memo.Lazy.force findlib in + let+ env = builder.env in + make_installed_env env builder.name findlib builder.env_nodes builder.profile) in { builder with env = Memo.Lazy.force installed_env } in @@ -712,8 +712,8 @@ module DB = struct "context-db-get" ~input:(module Context_name) (fun name -> - let+ contexts = all () in - List.find_exn contexts ~f:(fun c -> Context_name.equal name c.builder.name)) + let+ contexts = all () in + List.find_exn contexts ~f:(fun c -> Context_name.equal name c.builder.name)) in Memo.exec memo ;; diff --git a/src/dune_rules/coq/coq_lib.ml b/src/dune_rules/coq/coq_lib.ml index 3baf6f93b66..23361541633 100644 --- a/src/dune_rules/coq/coq_lib.ml +++ b/src/dune_rules/coq/coq_lib.ml @@ -72,7 +72,7 @@ and Dune : sig ; id : Id.t ; implicit : bool (* Only useful for the stdlib *) ; use_stdlib : bool - (* whether this theory uses the stdlib, eventually set to false for all libs *) + (* whether this theory uses the stdlib, eventually set to false for all libs *) ; src_root : Path.Build.t ; obj_root : Path.Build.t ; theories : (Loc.t * R.t) list Resolve.t @@ -95,7 +95,7 @@ end = struct ; id : Id.t ; implicit : bool (* Only useful for the stdlib *) ; use_stdlib : bool - (* whether this theory uses the stdlib, eventually set to false for all libs *) + (* whether this theory uses the stdlib, eventually set to false for all libs *) ; src_root : Path.Build.t ; obj_root : Path.Build.t ; theories : (Loc.t * R.t) list Resolve.t @@ -105,18 +105,18 @@ end = struct } let to_dyn - { loc - ; boot_id - ; id - ; implicit - ; use_stdlib - ; src_root - ; obj_root - ; theories - ; libraries - ; theories_closure - ; package - } + { loc + ; boot_id + ; id + ; implicit + ; use_stdlib + ; src_root + ; obj_root + ; theories + ; libraries + ; theories_closure + ; package + } = Dyn.( record @@ -433,11 +433,11 @@ module DB = struct ;; let resolve_theory - ~coq_lang_version - ~allow_private_deps - ~coq_db - ~boot_id - (loc, theory_name) + ~coq_lang_version + ~allow_private_deps + ~coq_db + ~boot_id + (loc, theory_name) = let open Resolve.Memo.O in let* theory = resolve ~coq_lang_version coq_db (loc, theory_name) in @@ -624,9 +624,9 @@ module DB = struct ;; let create_from_coqlib_stanzas - ~(parent : t option) - ~find_db - (entries : (Coq_stanza.Theory.t * Entry.t) list) + ~(parent : t option) + ~find_db + (entries : (Coq_stanza.Theory.t * Entry.t) list) = let boot_id = select_boot_id entries in let map = diff --git a/src/dune_rules/coq/coq_rules.ml b/src/dune_rules/coq/coq_rules.ml index 6b4db3b1bb9..0f3fba74485 100644 --- a/src/dune_rules/coq/coq_rules.ml +++ b/src/dune_rules/coq/coq_rules.ml @@ -106,8 +106,9 @@ let select_native_mode ~sctx ~dir (buildable : Coq_stanza.Buildable.t) = | Some x -> Memo.return @@ - if buildable.coq_lang_version < (0, 7) - && Super_context.context sctx |> Context.profile |> Profile.is_dev + if + buildable.coq_lang_version < (0, 7) + && Super_context.context sctx |> Context.profile |> Profile.is_dev then Coq_mode.VoOnly else x | None -> @@ -225,7 +226,8 @@ module Bootstrap : sig | No_stdlib (** We are in >= 0.8, however the user set stdlib = no , or we are compiling the prelude *) - | Stdlib of Coq_lib.t (** Regular case in >= 0.8 (or in < 0.8 + | Stdlib of Coq_lib.t + (** Regular case in >= 0.8 (or in < 0.8 (boot) was used *) val empty : t @@ -245,7 +247,8 @@ end = struct | No_stdlib (** We are in >= 0.8, however the user set stdlib = no , or we are compiling the prelude *) - | Stdlib of Coq_lib.t (** Regular case in >= 0.8 (or in < 0.8 + | Stdlib of Coq_lib.t + (** Regular case in >= 0.8 (or in < 0.8 (boot) was used *) (* For empty set of modules, we return Prelude which is kinda @@ -455,10 +458,10 @@ let ml_pack_and_meta_rule ~context ~all_libs (buildable : Coq_stanza.Buildable.t ;; let ml_flags_and_ml_pack_rule - ~context - ~lib_db - ~theories_deps - (buildable : Coq_stanza.Buildable.t) + ~context + ~lib_db + ~theories_deps + (buildable : Coq_stanza.Buildable.t) = let res = let open Resolve.Memo.O in @@ -484,17 +487,17 @@ let dep_theory_file ~dir ~wrapper_name = ;; let setup_coqdep_for_theory_rule - ~sctx - ~dir - ~loc - ~theories_deps - ~wrapper_name - ~source_rule - ~ml_flags - ~mlpack_rule - ~boot_flags - ~stanza_coqdep_flags - coq_modules + ~sctx + ~dir + ~loc + ~theories_deps + ~wrapper_name + ~source_rule + ~ml_flags + ~mlpack_rule + ~boot_flags + ~stanza_coqdep_flags + coq_modules = (* coqdep needs the full source + plugin's mlpack to be present :( *) let sources = List.rev_map ~f:Coq_module.source coq_modules in @@ -645,18 +648,18 @@ let deps_of ~dir ~boot_type ~wrapper_name ~mode coq_module = ;; let generic_coq_args - ~sctx - ~dir - ~wrapper_name - ~boot_flags - ~per_file_flags - ~mode - ~coq_prog - ~stanza_flags - ~ml_flags - ~theories_deps - ~theory_dirs - coq_module + ~sctx + ~dir + ~wrapper_name + ~boot_flags + ~per_file_flags + ~mode + ~coq_prog + ~stanza_flags + ~ml_flags + ~theories_deps + ~theory_dirs + coq_module = let+ coq_stanza_flags = let+ expander = Super_context.expander sctx ~dir in @@ -710,22 +713,22 @@ module Per_file = struct end let setup_coqc_rule - ~scope - ~loc - ~dir - ~sctx - ~coqc_dir - ~file_targets - ~stanza_flags - ~modules_flags - ~theories_deps - ~mode - ~wrapper_name - ~use_stdlib - ~ml_flags - ~theory_dirs - ~coq_lang_version - coq_module + ~scope + ~loc + ~dir + ~sctx + ~coqc_dir + ~file_targets + ~stanza_flags + ~modules_flags + ~theories_deps + ~mode + ~wrapper_name + ~use_stdlib + ~ml_flags + ~theory_dirs + ~coq_lang_version + coq_module = (* Process coqdep and generate rules *) let boot_type = @@ -910,10 +913,10 @@ let theory_context ~context ~scope ~coq_lang_version ~name buildable = (* Common context for extraction, almost the same than above *) let extraction_context - ~context - ~scope - ~coq_lang_version - (buildable : Coq_stanza.Buildable.t) + ~context + ~scope + ~coq_lang_version + (buildable : Coq_stanza.Buildable.t) = let coq_lib_db = Scope.coq_libs scope in let theories_deps = @@ -1073,8 +1076,9 @@ let coq_plugins_install_rules ~scope ~package ~dst_dir (s : Coq_stanza.Theory.t) let rules_for_lib lib = let info = Lib.info lib in (* Don't install libraries that don't belong to this package *) - if let name = Package.name package in - Option.equal Package.Name.equal (Lib_info.package info) (Some name) + if + let name = Package.name package in + Option.equal Package.Name.equal (Lib_info.package info) (Some name) then ( let loc = Lib_info.loc info in let plugins = Lib_info.plugins info in diff --git a/src/dune_rules/coq/coq_scope.ml b/src/dune_rules/coq/coq_scope.ml index a6f9e1d4450..35f65651b29 100644 --- a/src/dune_rules/coq/coq_scope.ml +++ b/src/dune_rules/coq/coq_scope.ml @@ -19,10 +19,10 @@ let public_theories context public_libs coq_stanzas = ;; let coq_scopes_by_dir - db_by_project_dir - projects_by_dir - public_theories - coq_stanzas_by_project_dir + db_by_project_dir + projects_by_dir + public_theories + coq_stanzas_by_project_dir = let parent = Some public_theories in let find_db dir = snd (Find_closest_source_dir.find_by_dir db_by_project_dir ~dir) in diff --git a/src/dune_rules/coq/coq_sources.ml b/src/dune_rules/coq/coq_sources.ml index 87261de5352..ea24237b004 100644 --- a/src/dune_rules/coq/coq_sources.ml +++ b/src/dune_rules/coq/coq_sources.ml @@ -8,7 +8,7 @@ open Coq_stanza type t = { libraries : Coq_module.t list Coq_lib_name.Map.t ; directories : Path.Build.t list Coq_lib_name.Map.t - (* [directories] is used to compute the include paths for Coq's native + (* [directories] is used to compute the include paths for Coq's native mode *) ; extract : Coq_module.t Loc.Map.t ; rev_map : [ `Theory of Theory.t | `Extraction of Extraction.t ] Coq_module.Map.t diff --git a/src/dune_rules/cram/cram_exec.ml b/src/dune_rules/cram/cram_exec.ml index 885d64be36a..09888192b87 100644 --- a/src/dune_rules/cram/cram_exec.ml +++ b/src/dune_rules/cram/cram_exec.ml @@ -96,18 +96,18 @@ let translate_path_for_sh = then fun fn -> Fiber.return (Path.to_absolute_filename fn) else fun fn -> - let cygpath = - let path = Env_path.path Env.initial in - Bin.which ~path "cygpath" - in - match cygpath with - | None -> User_error.raise [ Pp.text "Unable to find cygpath in PATH" ] - | Some cygpath -> - Process.run_capture_line - ~display:Quiet - Strict - cygpath - [ Path.to_absolute_filename fn ] + let cygpath = + let path = Env_path.path Env.initial in + Bin.which ~path "cygpath" + in + match cygpath with + | None -> User_error.raise [ Pp.text "Unable to find cygpath in PATH" ] + | Some cygpath -> + Process.run_capture_line + ~display:Quiet + Strict + cygpath + [ Path.to_absolute_filename fn ] ;; (* Quote a filename for sh, independently of whether we are on Windows or Unix. diff --git a/src/dune_rules/cram/cram_rules.ml b/src/dune_rules/cram/cram_rules.ml index 5b8ef06d6f1..3a01f023552 100644 --- a/src/dune_rules/cram/cram_rules.ml +++ b/src/dune_rules/cram/cram_rules.ml @@ -47,10 +47,10 @@ let missing_run_t (error : Cram_test.t) = ;; let test_rule - ~sctx - ~dir - ({ alias; loc; enabled_if; deps; locks; sandbox; packages = _ } : Spec.t) - (test : (Cram_test.t, error) result) + ~sctx + ~dir + ({ alias; loc; enabled_if; deps; locks; sandbox; packages = _ } : Spec.t) + (test : (Cram_test.t, error) result) = let module Alias_rules = Simple_rules.Alias_rules in let aliases = Alias.Name.Set.to_list_map alias ~f:(Alias.make ~dir) in diff --git a/src/dune_rules/ctypes/ctypes_field.ml b/src/dune_rules/ctypes/ctypes_field.ml index 0bfbdcae1cd..d85ed2395a3 100644 --- a/src/dune_rules/ctypes/ctypes_field.ml +++ b/src/dune_rules/ctypes/ctypes_field.ml @@ -127,8 +127,8 @@ module Function_description = struct end let c_generated_functions_cout_c_of_lib - ~external_library_name - (fd : Function_description.t) + ~external_library_name + (fd : Function_description.t) = sprintf "%s__c_cout_generated_functions__%s__%s.c" diff --git a/src/dune_rules/ctypes/ctypes_rules.ml b/src/dune_rules/ctypes/ctypes_rules.ml index a5114d94d7c..21be89e5bcf 100644 --- a/src/dune_rules/ctypes/ctypes_rules.ml +++ b/src/dune_rules/ctypes/ctypes_rules.ml @@ -68,10 +68,10 @@ let write_c_types_includer_module ~type_description_functor ~c_generated_types_m ;; let write_entry_point_module - ~ctypes - ~type_description_instance - ~function_description - ~c_types_includer_module + ~ctypes + ~type_description_instance + ~function_description + ~c_types_includer_module = let contents = Pp.concat @@ -123,11 +123,11 @@ let type_gen_gen ~expander ~headers ~type_description_functor = ;; let function_gen_gen - ~expander - ~(concurrency : Ctypes_field.Concurrency_policy.t) - ~(errno_policy : Ctypes_field.Errno_policy.t) - ~headers - ~function_description_functor + ~expander + ~(concurrency : Ctypes_field.Concurrency_policy.t) + ~(errno_policy : Ctypes_field.Errno_policy.t) + ~headers + ~function_description_functor = let open Action_builder.O in let module_name = Module_name.to_string function_description_functor in @@ -167,14 +167,14 @@ let function_gen_gen ;; let build_c_program - ~foreign_archives_deps - ~sctx - ~dir - ~source_files - ~scope - ~cflags - ~output - ~deps + ~foreign_archives_deps + ~sctx + ~dir + ~source_files + ~scope + ~cflags + ~output + ~deps = let ctx = Super_context.context sctx in let ocaml = Context.ocaml ctx in diff --git a/src/dune_rules/dep_conf_eval.ml b/src/dune_rules/dep_conf_eval.ml index 76c7760f2d2..3d6aaaed3a4 100644 --- a/src/dune_rules/dep_conf_eval.ml +++ b/src/dune_rules/dep_conf_eval.ml @@ -268,8 +268,8 @@ and named_paths_builder ~expander l = (match Option.List.all (List.map x ~f:(function - | Simple x -> Some x - | Other _ -> None)) + | Simple x -> Some x + | Other _ -> None)) with | Some x -> let open Memo.O in diff --git a/src/dune_rules/dep_rules.ml b/src/dune_rules/dep_rules.ml index 0e890775ac3..3bf173b0484 100644 --- a/src/dune_rules/dep_rules.ml +++ b/src/dune_rules/dep_rules.ml @@ -10,11 +10,11 @@ let transitive_deps_contents modules = ;; let ooi_deps - { vimpl; sctx; dir; obj_dir; modules = _; stdlib = _; sandbox = _ } - ~dune_version - ~vlib_obj_map - ~(ml_kind : Ml_kind.t) - (sourced_module : Modules.Sourced_module.t) + { vimpl; sctx; dir; obj_dir; modules = _; stdlib = _; sandbox = _ } + ~dune_version + ~vlib_obj_map + ~(ml_kind : Ml_kind.t) + (sourced_module : Modules.Sourced_module.t) = let m = Modules.Sourced_module.to_module sourced_module in let cm_kind = diff --git a/src/dune_rules/dir_contents.ml b/src/dune_rules/dir_contents.ml index 8c07e0150fc..97bb14e2175 100644 --- a/src/dune_rules/dir_contents.ml +++ b/src/dune_rules/dir_contents.ml @@ -304,9 +304,9 @@ end = struct ;; let make_group_root - sctx - ~dir - { Dir_status.Group_root.qualification; dune_file; source_dir; components } + sctx + ~dir + { Dir_status.Group_root.qualification; dune_file; source_dir; components } = let include_subdirs = let loc, qualif_mode = qualification in @@ -318,89 +318,89 @@ end = struct Memo.lazy_ ~human_readable_description:(fun () -> human_readable_description dir) (fun () -> - let ctx = Super_context.context sctx in - let stanzas = Dune_file.stanzas dune_file in - let project = Dune_file.project dune_file in - let+ (files, subdirs), rules = - Rules.collect (fun () -> - Memo.fork_and_join - (fun () -> - stanzas - >>= load_text_files - sctx - source_dir - ~src_dir:(Dune_file.dir dune_file) - ~dir) - (fun () -> - Memo.parallel_map - components - ~f:(fun { dir; path_to_group_root; source_dir; stanzas } -> - let+ files = - load_text_files + let ctx = Super_context.context sctx in + let stanzas = Dune_file.stanzas dune_file in + let project = Dune_file.project dune_file in + let+ (files, subdirs), rules = + Rules.collect (fun () -> + Memo.fork_and_join + (fun () -> + stanzas + >>= load_text_files sctx source_dir - stanzas - ~src_dir:(Source_tree.Dir.path source_dir) - ~dir - in - { Source_file_dir.dir; path_to_root = path_to_group_root; files }))) - in - let dirs = { Source_file_dir.dir; path_to_root = []; files } :: subdirs in - let lib_config = - let+ ocaml = Context.ocaml ctx in - ocaml.lib_config - in - let ml = - Memo.lazy_ (fun () -> - let lookup_vlib = lookup_vlib sctx ~current_dir:dir in - let libs = Scope.DB.find_by_dir dir >>| Scope.libs in - let* expander = Super_context.expander sctx ~dir in - stanzas - >>= Ml_sources.make - ~expander - ~dir - ~project - ~libs - ~lib_config - ~loc - ~lookup_vlib - ~include_subdirs - ~dirs) - in - let foreign_sources = - Memo.lazy_ (fun () -> - let dune_version = Dune_project.dune_version project in - stanzas >>| Foreign_sources.make ~dune_version ~dirs) - in - let coq = - Memo.lazy_ (fun () -> - stanzas >>| Coq_sources.of_dir ~dir ~dirs ~include_subdirs) - in - let subdirs = - List.map subdirs ~f:(fun { Source_file_dir.dir; path_to_root = _; files } -> - { kind = Group_part - ; dir - ; text_files = files - ; ml - ; foreign_sources - ; mlds = Memo.lazy_ (fun () -> build_mlds_map dune_file ~dir ~files) - ; coq - }) - in - let root = - { kind = Group_root subdirs - ; dir - ; text_files = files - ; ml - ; foreign_sources - ; mlds = Memo.lazy_ (fun () -> build_mlds_map dune_file ~dir ~files) - ; coq - } - in - { Standalone_or_root.root - ; rules - ; subdirs = Path.Build.Map.of_list_map_exn subdirs ~f:(fun x -> x.dir, x) - }) + ~src_dir:(Dune_file.dir dune_file) + ~dir) + (fun () -> + Memo.parallel_map + components + ~f:(fun { dir; path_to_group_root; source_dir; stanzas } -> + let+ files = + load_text_files + sctx + source_dir + stanzas + ~src_dir:(Source_tree.Dir.path source_dir) + ~dir + in + { Source_file_dir.dir; path_to_root = path_to_group_root; files }))) + in + let dirs = { Source_file_dir.dir; path_to_root = []; files } :: subdirs in + let lib_config = + let+ ocaml = Context.ocaml ctx in + ocaml.lib_config + in + let ml = + Memo.lazy_ (fun () -> + let lookup_vlib = lookup_vlib sctx ~current_dir:dir in + let libs = Scope.DB.find_by_dir dir >>| Scope.libs in + let* expander = Super_context.expander sctx ~dir in + stanzas + >>= Ml_sources.make + ~expander + ~dir + ~project + ~libs + ~lib_config + ~loc + ~lookup_vlib + ~include_subdirs + ~dirs) + in + let foreign_sources = + Memo.lazy_ (fun () -> + let dune_version = Dune_project.dune_version project in + stanzas >>| Foreign_sources.make ~dune_version ~dirs) + in + let coq = + Memo.lazy_ (fun () -> + stanzas >>| Coq_sources.of_dir ~dir ~dirs ~include_subdirs) + in + let subdirs = + List.map subdirs ~f:(fun { Source_file_dir.dir; path_to_root = _; files } -> + { kind = Group_part + ; dir + ; text_files = files + ; ml + ; foreign_sources + ; mlds = Memo.lazy_ (fun () -> build_mlds_map dune_file ~dir ~files) + ; coq + }) + in + let root = + { kind = Group_root subdirs + ; dir + ; text_files = files + ; ml + ; foreign_sources + ; mlds = Memo.lazy_ (fun () -> build_mlds_map dune_file ~dir ~files) + ; coq + } + in + { Standalone_or_root.root + ; rules + ; subdirs = Path.Build.Map.of_list_map_exn subdirs ~f:(fun x -> x.dir, x) + }) in { Standalone_or_root.contents } ;; diff --git a/src/dune_rules/dir_status.ml b/src/dune_rules/dir_status.ml index de7f19f1303..54b01863eed 100644 --- a/src/dune_rules/dir_status.ml +++ b/src/dune_rules/dir_status.ml @@ -144,9 +144,9 @@ let jsoo_wasm_enabled ~jsoo_enabled ~dir ~(buildable : Buildable.t) = ;; let directory_targets_of_executables - ~jsoo_enabled - ~dir - { Executables.names; modes; enabled_if; buildable; _ } + ~jsoo_enabled + ~dir + { Executables.names; modes; enabled_if; buildable; _ } = let* directory_targets = match Executables.Link_mode.(Map.mem modes wasm) with @@ -165,9 +165,9 @@ let directory_targets_of_executables ;; let directory_targets_of_library - ~jsoo_enabled - ~dir - { Library.sub_systems; name; enabled_if; buildable; _ } + ~jsoo_enabled + ~dir + { Library.sub_systems; name; enabled_if; buildable; _ } = let* directory_targets = match Sub_system_name.Map.find sub_systems Inline_tests_info.Tests.name with @@ -175,18 +175,18 @@ let directory_targets_of_library when Inline_tests_info.Mode_conf.Set.mem modes (Jsoo Wasm) -> jsoo_wasm_enabled ~jsoo_enabled ~dir ~buildable >>| (function - | false -> Path.Build.Map.empty - | true -> - let dir_target = - let lib_name = Lib_name.Local.to_string (snd name) in - let name = sprintf "inline_test_runner_%s" lib_name in - let inline_test_dir = - let inline_test_name = sprintf "%s.inline-tests" lib_name in - Path.Build.relative dir ("." ^ inline_test_name) - in - Path.Build.relative inline_test_dir (name ^ Js_of_ocaml.Ext.wasm_dir) - in - Path.Build.Map.singleton dir_target loc) + | false -> Path.Build.Map.empty + | true -> + let dir_target = + let lib_name = Lib_name.Local.to_string (snd name) in + let name = sprintf "inline_test_runner_%s" lib_name in + let inline_test_dir = + let inline_test_name = sprintf "%s.inline-tests" lib_name in + Path.Build.relative dir ("." ^ inline_test_name) + in + Path.Build.relative inline_test_dir (name ^ Js_of_ocaml.Ext.wasm_dir) + in + Path.Build.Map.singleton dir_target loc) >>= when_enabled ~dir ~enabled_if | _ -> Memo.return Path.Build.Map.empty in @@ -320,8 +320,8 @@ end = struct let src_dir = Source_tree.Dir.path st_dir in Pkg_rules.lock_dir_path (Context_name.of_string ctx) >>| (function - | None -> false - | Some of_ -> Path.Source.is_descendant ~of_ src_dir) + | None -> false + | Some of_ -> Path.Source.is_descendant ~of_ src_dir) >>= (function | true -> Memo.return Lock_dir | false -> diff --git a/src/dune_rules/dune_env.ml b/src/dune_rules/dune_env.ml index b0aeffb4808..42854dcd1ee 100644 --- a/src/dune_rules/dune_env.ml +++ b/src/dune_rules/dune_env.ml @@ -94,23 +94,23 @@ let dyn_of_config { bin_annot; _ } = ;; let equal_config - { flags - ; foreign_flags - ; link_flags - ; env_vars - ; binaries - ; inline_tests - ; menhir - ; odoc - ; js_of_ocaml - ; wasm_of_ocaml - ; coq - ; format_config - ; error_on_use - ; warn_on_load - ; bin_annot - } - t + { flags + ; foreign_flags + ; link_flags + ; env_vars + ; binaries + ; inline_tests + ; menhir + ; odoc + ; js_of_ocaml + ; wasm_of_ocaml + ; coq + ; format_config + ; error_on_use + ; warn_on_load + ; bin_annot + } + t = Ocaml_flags.Spec.equal flags t.flags && Foreign_language.Dict.equal diff --git a/src/dune_rules/dune_file.ml b/src/dune_rules/dune_file.ml index 873da8cfc8c..20919ed809f 100644 --- a/src/dune_rules/dune_file.ml +++ b/src/dune_rules/dune_file.ml @@ -230,13 +230,13 @@ end = struct ;; let write - oc - ~(context : Context_name.t) - ~ocaml_config - ~target - ~exec_dir - ~plugin - ~plugin_contents + oc + ~(context : Context_name.t) + ~ocaml_config + ~target + ~exec_dir + ~plugin + ~plugin_contents = let ocamlc_config = let vars = @@ -409,14 +409,14 @@ module Eval = struct |> Path.to_string_maybe_quoted) (Path.Source.to_string_maybe_quoted eval.dir)) (fun () -> - let* ast, include_context = - Include_stanza.load_sexps ~context:include_context (loc, include_file) - in - let* stanzas, dynamic_includes = parse_stanzas ast ~file:None ~eval in - let+ dynamic = - collect_dynamic_includes eval include_context origin dynamic_includes - in - List.rev_append stanzas dynamic)) + let* ast, include_context = + Include_stanza.load_sexps ~context:include_context (loc, include_file) + in + let* stanzas, dynamic_includes = parse_stanzas ast ~file:None ~eval in + let+ dynamic = + collect_dynamic_includes eval include_context origin dynamic_includes + in + List.rev_append stanzas dynamic)) ;; let set_dynamic_stanzas t ~context ~eval ~dynamic_includes = diff --git a/src/dune_rules/dune_file0.ml b/src/dune_rules/dune_file0.ml index 7419669d6d2..72567adfcbc 100644 --- a/src/dune_rules/dune_file0.ml +++ b/src/dune_rules/dune_file0.ml @@ -145,12 +145,13 @@ module Ast = struct ] in User_error.raise ~loc ~hints msg) - else if match dn with - | "" | "." -> - let hints = [ Pp.textf "did you mean (%s *)?" field_name ] in - User_error.raise ~loc ~hints msg - | ".." -> true - | _ -> false + else if + match dn with + | "" | "." -> + let hints = [ Pp.textf "did you mean (%s *)?" field_name ] in + User_error.raise ~loc ~hints msg + | ".." -> true + | _ -> false then User_error.raise ~loc msg else loc, dn) ;; @@ -293,12 +294,12 @@ let statically_evaluated_stanzas = Ast.statically_evaluated_stanzas type decoder = { decode : 'a. Dune_lang.Ast.t list -> 'a Dune_lang.Decoder.t -> 'a } let rec evaluate_includes - ~(decoder : decoder) - ~context - ~inside_subdir - ~inside_include - (prefix : string) - (stanzas : Ast.t list) + ~(decoder : decoder) + ~context + ~inside_subdir + ~inside_include + (prefix : string) + (stanzas : Ast.t list) = Memo.parallel_map stanzas ~f:(function | Include { loc; file } -> @@ -540,8 +541,9 @@ let load ~dir (status : Source_dir_status.t) project ~files ~parent = let file = if status = Data_only then None - else if Dune_project.accept_alternative_dune_file_name project - && Filename.Set.mem files alternative_fname + else if + Dune_project.accept_alternative_dune_file_name project + && Filename.Set.mem files alternative_fname then Some alternative_fname else if Filename.Set.mem files fname then Some fname diff --git a/src/dune_rules/dune_project.ml b/src/dune_rules/dune_project.ml index f25b1e595be..86f8e3b7d07 100644 --- a/src/dune_rules/dune_project.ml +++ b/src/dune_rules/dune_project.ml @@ -78,37 +78,37 @@ let explicit_js_mode t = t.explicit_js_mode let dune_version t = t.dune_version let to_dyn - { name - ; root - ; version - ; dune_version - ; info - ; project_file - ; parsing_context = _ - ; extension_args = _ - ; stanza_parser = _ - ; packages - ; implicit_transitive_deps - ; wrapped_executables - ; map_workspace_root - ; executables_implicit_empty_intf - ; accept_alternative_dune_file_name - ; generate_opam_files - ; warnings - ; use_standard_c_and_cxx_flags - ; file_key - ; dialects - ; explicit_js_mode - ; format_config - ; subst_config - ; strict_package_deps - ; allow_approximate_merlin - ; sources = _ - ; cram - ; expand_aliases_in_sandbox - ; opam_file_location - ; including_hidden_packages = _ - } + { name + ; root + ; version + ; dune_version + ; info + ; project_file + ; parsing_context = _ + ; extension_args = _ + ; stanza_parser = _ + ; packages + ; implicit_transitive_deps + ; wrapped_executables + ; map_workspace_root + ; executables_implicit_empty_intf + ; accept_alternative_dune_file_name + ; generate_opam_files + ; warnings + ; use_standard_c_and_cxx_flags + ; file_key + ; dialects + ; explicit_js_mode + ; format_config + ; subst_config + ; strict_package_deps + ; allow_approximate_merlin + ; sources = _ + ; cram + ; expand_aliases_in_sandbox + ; opam_file_location + ; including_hidden_packages = _ + } = let open Dyn in record @@ -534,11 +534,12 @@ let encode : t -> Dune_lang.t list = ; (match use_standard_c_and_cxx_flags with | None -> None | Some b -> - if not - (Option.equal - Bool.equal - (Some b) - (use_standard_c_and_cxx_flags_default ~lang)) + if + not + (Option.equal + Bool.equal + (Some b) + (use_standard_c_and_cxx_flags_default ~lang)) then Some (constr "use_standard_c_and_cxx_flags" bool b) else None) ; (if Bool.equal cram (cram_default ~lang) @@ -639,12 +640,12 @@ let filter_packages t ~f = let including_hidden_packages t = t.including_hidden_packages let make_packages - ~opam_packages - ~dir - ~generate_opam_files - ~opam_file_location - packages - name + ~opam_packages + ~dir + ~generate_opam_files + ~opam_file_location + packages + name = (match packages, Option.bind ~f:Dune_project_name.name name with | [ p ], Some name -> @@ -727,14 +728,14 @@ let make_packages ;; let parse_packages - name - ~info - ~dir - ~version - packages - opam_file_location - ~generate_opam_files - opam_packages + name + ~info + ~dir + ~version + packages + opam_file_location + ~generate_opam_files + opam_packages = forbid_opam_files_relative_to_project opam_file_location opam_packages; let open Memo.O in diff --git a/src/dune_rules/env_binaries.ml b/src/dune_rules/env_binaries.ml index 73173367af1..6ad46f26290 100644 --- a/src/dune_rules/env_binaries.ml +++ b/src/dune_rules/env_binaries.ml @@ -22,9 +22,9 @@ let impl dir = let* profile = Per_context.profile ctx in Dune_file.find_stanzas stanzas Dune_env.key >>| (function - | [ config ] -> Some config - | [] -> None - | _ :: _ :: _ -> assert false) + | [ config ] -> Some config + | [] -> None + | _ :: _ :: _ -> assert false) >>| (function | None -> [] | Some stanza -> diff --git a/src/dune_rules/env_node.ml b/src/dune_rules/env_node.ml index d3433cc4d6c..e826ee8e82f 100644 --- a/src/dune_rules/env_node.ml +++ b/src/dune_rules/env_node.ml @@ -20,13 +20,13 @@ let expand_str_lazy expander sw = ;; let make - ~dir - ~inherit_from - ~config_stanza - ~profile - ~expander - ~default_env - ~default_artifacts + ~dir + ~inherit_from + ~config_stanza + ~profile + ~expander + ~default_env + ~default_artifacts = let open Memo.O in let config = Dune_env.find config_stanza ~profile in diff --git a/src/dune_rules/env_stanza_db.ml b/src/dune_rules/env_stanza_db.ml index abc47814b58..138f3fa8e47 100644 --- a/src/dune_rules/env_stanza_db.ml +++ b/src/dune_rules/env_stanza_db.ml @@ -34,9 +34,10 @@ module Node = struct let rec by_dir dir = let parent = let* project = Dune_load.find_project ~dir in - if Path.Source.equal - (Path.Build.drop_build_context_exn dir) - (Dune_project.root project) + if + Path.Source.equal + (Path.Build.drop_build_context_exn dir) + (Dune_project.root project) then by_context dir else ( match Path.Build.parent dir with @@ -110,11 +111,11 @@ let inline_tests ~dir = module Inherit = struct let for_context - (type a) - ~name - ~(root : Context_name.t -> Dune_project.t -> a Memo.t) - (context : Context_name.t) - ~(f : parent:a Memo.t -> dir:Path.Build.t -> Dune_env.config -> a Memo.t) + (type a) + ~name + ~(root : Context_name.t -> Dune_project.t -> a Memo.t) + (context : Context_name.t) + ~(f : parent:a Memo.t -> dir:Path.Build.t -> Dune_env.config -> a Memo.t) = let for_context = Memo.Lazy.create (fun () -> @@ -129,12 +130,12 @@ module Inherit = struct (sprintf "%s-root" name) ~input:(module Path.Source) (fun dir -> - let* projects_by_root = Dune_load.projects_by_root () - and* envs = Memo.Lazy.force for_context in - let project = Path.Source.Map.find_exn projects_by_root dir in - let root = root context project in - let dir = Path.Build.append_source (Context_name.build_dir context) dir in - List.fold_left envs ~init:root ~f:(fun acc env -> f ~parent:acc ~dir env)) + let* projects_by_root = Dune_load.projects_by_root () + and* envs = Memo.Lazy.force for_context in + let project = Path.Source.Map.find_exn projects_by_root dir in + let root = root context project in + let dir = Path.Build.append_source (Context_name.build_dir context) dir in + List.fold_left envs ~init:root ~f:(fun acc env -> f ~parent:acc ~dir env)) |> Memo.exec in let module Non_rec = struct diff --git a/src/dune_rules/exe.ml b/src/dune_rules/exe.ml index 3eaa16f1adf..08b778fb382 100644 --- a/src/dune_rules/exe.ml +++ b/src/dune_rules/exe.ml @@ -79,10 +79,10 @@ module Linkage = struct let cma_flags = [ "-a" ] let of_user_config - (ocaml : Ocaml_toolchain.t) - ~dynamically_linked_foreign_archives - ~loc - (m : Executables.Link_mode.t) + (ocaml : Ocaml_toolchain.t) + ~dynamically_linked_foreign_archives + ~loc + (m : Executables.Link_mode.t) = match m with | Jsoo JS -> js @@ -158,17 +158,17 @@ let exe_path_from_name cctx ~name ~(linkage : Linkage.t) = ;; let link_exe - ~loc - ~name - ~(linkage : Linkage.t) - ~linkage_mode - ~cm_files - ~link_time_code_gen - ~promote - ~link_args - ~o_files - ?(sandbox = Sandbox_config.default) - cctx + ~loc + ~name + ~(linkage : Linkage.t) + ~linkage_mode + ~cm_files + ~link_time_code_gen + ~promote + ~link_args + ~o_files + ?(sandbox = Sandbox_config.default) + cctx = let sctx = Compilation_context.super_context cctx in let ctx = Super_context.context sctx in @@ -243,15 +243,15 @@ let link_exe ;; let link_js - ~name - ~loc - ~obj_dir - ~top_sorted_modules - ~link_args - ~promote - ~link_time_code_gen - ~jsoo_mode - cctx + ~name + ~loc + ~obj_dir + ~top_sorted_modules + ~link_args + ~promote + ~link_time_code_gen + ~jsoo_mode + cctx = let in_context = Compilation_context.js_of_ocaml cctx @@ -283,14 +283,14 @@ let link_js type dep_graphs = { for_exes : Module.t list Action_builder.t list } let link_many - ?(link_args = Action_builder.return Command.Args.empty) - ?o_files - ?(embed_in_plugin_libraries = []) - ?sandbox - ~programs - ~linkages - ~promote - cctx + ?(link_args = Action_builder.return Command.Args.empty) + ?o_files + ?(embed_in_plugin_libraries = []) + ?sandbox + ~programs + ~linkages + ~promote + cctx = let o_files = match o_files with @@ -379,14 +379,14 @@ let link_many ;; let build_and_link_many - ?link_args - ?o_files - ?embed_in_plugin_libraries - ?sandbox - ~programs - ~linkages - ~promote - cctx + ?link_args + ?o_files + ?embed_in_plugin_libraries + ?sandbox + ~programs + ~linkages + ~promote + cctx = let* () = Module_compilation.build_all cctx in let* () = @@ -405,14 +405,14 @@ let build_and_link_many ;; let build_and_link - ?link_args - ?o_files - ?embed_in_plugin_libraries - ?sandbox - ~program - ~linkages - ~promote - cctx + ?link_args + ?o_files + ?embed_in_plugin_libraries + ?sandbox + ~program + ~linkages + ~promote + cctx = build_and_link_many ?link_args diff --git a/src/dune_rules/exe_rules.ml b/src/dune_rules/exe_rules.ml index f083a9dea15..fc9765d0143 100644 --- a/src/dune_rules/exe_rules.ml +++ b/src/dune_rules/exe_rules.ml @@ -4,12 +4,12 @@ open Memo.O let first_exe (exes : Executables.t) = snd (Nonempty_list.hd exes.names) let linkages - ~dynamically_linked_foreign_archives - (ocaml : Ocaml_toolchain.t) - ~(exes : Executables.t) - ~explicit_js_mode - ~jsoo_enabled_modes - ~jsoo_is_whole_program + ~dynamically_linked_foreign_archives + (ocaml : Ocaml_toolchain.t) + ~(exes : Executables.t) + ~explicit_js_mode + ~jsoo_enabled_modes + ~jsoo_is_whole_program = let module L = Executables.Link_mode in let l = @@ -58,9 +58,10 @@ let linkages in (* If bytecode was requested but not native or best version, add custom linking *) - if L.Map.mem exes.modes L.byte - && (not (L.Map.mem exes.modes L.native)) - && not (L.Map.mem exes.modes L.exe) + if + L.Map.mem exes.modes L.byte + && (not (L.Map.mem exes.modes L.native)) + && not (L.Map.mem exes.modes L.exe) then Exe.Linkage.custom ocaml.version :: l else l ;; @@ -89,13 +90,13 @@ let programs ~modules ~(exes : Executables.t) = ;; let o_files - sctx - ~dir - ~expander - ~(exes : Executables.t) - ~linkages - ~dir_contents - ~requires_compile + sctx + ~dir + ~expander + ~(exes : Executables.t) + ~linkages + ~dir_contents + ~requires_compile = if not (Executables.has_foreign exes) then Memo.return @@ Mode.Map.empty @@ -136,14 +137,14 @@ let o_files ;; let executables_rules - ~sctx - ~dir - ~expander - ~dir_contents - ~scope - ~compile_info - ~embed_in_plugin_libraries - (exes : Executables.t) + ~sctx + ~dir + ~expander + ~dir_contents + ~scope + ~compile_info + ~embed_in_plugin_libraries + (exes : Executables.t) = (* Use "eobjs" rather than "objs" to avoid a potential conflict with a library of the same name *) diff --git a/src/dune_rules/expander.ml b/src/dune_rules/expander.ml index a6512635195..265aeedd8d0 100644 --- a/src/dune_rules/expander.ml +++ b/src/dune_rules/expander.ml @@ -242,9 +242,9 @@ type nonrec expansion_result = let static v = Direct (Without v) let[@inline never] invalid_use_of_target_variable - t - ~(source : Dune_lang.Template.Pform.t) - ~var_multiplicity + t + ~(source : Dune_lang.Template.Pform.t) + ~var_multiplicity = match t.expanding_what with | Nothing_special | Deps_like_field -> isn't_allowed_in_this_position ~source @@ -604,10 +604,10 @@ let env_macro t source macro_invocation = ;; let expand_pform_macro - (context : Context.t) - ~dir - ~source - (macro_invocation : Pform.Macro_invocation.t) + (context : Context.t) + ~dir + ~source + (macro_invocation : Pform.Macro_invocation.t) = let s = Pform.Macro_invocation.Args.whole macro_invocation in match macro_invocation.macro with @@ -737,20 +737,20 @@ let describe_source ~source = let expand_pform t ~source pform = Action_builder.push_stack_frame (fun () -> - match - match - expand_pform_gen - ~context:t.context - ~bindings:t.bindings - ~dir:t.dir - ~source - pform - with - | Direct v -> v - | Need_full_expander f -> f t - with - | With x -> x - | Without x -> Action_builder.of_memo x) + match + match + expand_pform_gen + ~context:t.context + ~bindings:t.bindings + ~dir:t.dir + ~source + pform + with + | Direct v -> v + | Need_full_expander f -> f t + with + | With x -> x + | Without x -> Action_builder.of_memo x) ~human_readable_description:(fun () -> describe_source ~source) ;; @@ -770,14 +770,14 @@ let expand_str_partial t template = ;; let make_root - ~project - ~scope - ~scope_host - ~(context : Context.t) - ~env - ~public_libs - ~public_libs_host - ~artifacts_host + ~project + ~scope + ~scope_host + ~(context : Context.t) + ~env + ~public_libs + ~public_libs_host + ~artifacts_host = { dir = Context.build_dir context ; env @@ -817,20 +817,20 @@ module No_deps = struct let expand_pform_no_deps t ~source pform = Memo.push_stack_frame (fun () -> - match - match - expand_pform_gen - ~context:t.context - ~bindings:t.bindings - ~dir:t.dir - ~source - pform - with - | Direct v -> v - | Need_full_expander f -> f t - with - | With _ -> isn't_allowed_in_this_position ~source - | Without x -> x) + match + match + expand_pform_gen + ~context:t.context + ~bindings:t.bindings + ~dir:t.dir + ~source + pform + with + | Direct v -> v + | Need_full_expander f -> f t + with + | With _ -> isn't_allowed_in_this_position ~source + | Without x -> x) ~human_readable_description:(fun () -> describe_source ~source) ;; diff --git a/src/dune_rules/fdo.ml b/src/dune_rules/fdo.ml index d90109508f7..7ba6a4ceefe 100644 --- a/src/dune_rules/fdo.ml +++ b/src/dune_rules/fdo.ml @@ -192,10 +192,11 @@ module Linker_script = struct match Context.fdo_target_exe ctx with | None -> None | Some fdo_target_exe -> - if let ocaml = Compilation_context.ocaml cctx in - Path.equal name fdo_target_exe - && (Ocaml.Version.supports_function_sections ocaml.version - || Ocaml_config.is_dev_version ocaml.ocaml_config) + if + let ocaml = Compilation_context.ocaml cctx in + Path.equal name fdo_target_exe + && (Ocaml.Version.supports_function_sections ocaml.version + || Ocaml_config.is_dev_version ocaml.ocaml_config) then Some (linker_script_rule cctx fdo_target_exe) else None ;; diff --git a/src/dune_rules/file_binding.ml b/src/dune_rules/file_binding.ml index c9dd15d0b5e..7867dc5c799 100644 --- a/src/dune_rules/file_binding.ml +++ b/src/dune_rules/file_binding.ml @@ -4,7 +4,7 @@ open Memo.O type ('src, 'dst) t = { src : 'src ; dst : 'dst option - (* The [dune_syntax] field is used for validation which has different + (* The [dune_syntax] field is used for validation which has different behaviour depending on the version of dune syntax in use. *) ; dune_syntax : Syntax.Version.t ; dir : Path.Source.t option @@ -41,10 +41,10 @@ let escaping_paths_in_install_stanza = ;; let validate_dst_for_install_stanza - ~relative_dst_path_starts_with_parent_error_when - ~loc - ~dst - ~dir + ~relative_dst_path_starts_with_parent_error_when + ~loc + ~dst + ~dir = match relative_path_starts_with_parent dst with | false -> Memo.return () diff --git a/src/dune_rules/findlib.ml b/src/dune_rules/findlib.ml index 73228dde5e4..922f5777bf4 100644 --- a/src/dune_rules/findlib.ml +++ b/src/dune_rules/findlib.ml @@ -199,9 +199,10 @@ let to_dune_library (t : Findlib.Package.t) ~dir_contents ~ext_lib ~external_loc match Filename.check_suffix fname ext with | false -> Ok None | true -> - if (* We add this hack to skip manually mangled + if + (* We add this hack to skip manually mangled libraries *) - String.contains_double_underscore fname + String.contains_double_underscore fname then Ok None else ( match diff --git a/src/dune_rules/foreign_rules.ml b/src/dune_rules/foreign_rules.ml index fb33489e9e7..219f328eb29 100644 --- a/src/dune_rules/foreign_rules.ml +++ b/src/dune_rules/foreign_rules.ml @@ -198,12 +198,12 @@ let include_dir_flags ~expander ~dir ~include_dirs = ;; let build_c - ~(kind : Foreign_language.t) - ~sctx - ~dir - ~expander - ~include_flags - (loc, (src : Foreign.Source.t), dst) + ~(kind : Foreign_language.t) + ~sctx + ~dir + ~expander + ~include_flags + (loc, (src : Foreign.Source.t), dst) = let ctx = Super_context.context sctx in let* project = Dune_load.find_project ~dir in @@ -256,10 +256,11 @@ let build_c | Some src_dir -> Source_tree.is_vendored src_dir | None -> Memo.return false in - if Dune_project.dune_version project >= (2, 8) - && Option.is_none use_standard_flags - && (not is_vendored) - && not has_standard + if + Dune_project.dune_version project >= (2, 8) + && Option.is_none use_standard_flags + && (not is_vendored) + && not has_standard then User_warning.emit ~loc @@ -313,12 +314,12 @@ let build_c (* TODO: [requires] is a confusing name, probably because it's too general: it looks like it's a list of libraries we depend on. *) let build_o_files - ~sctx - ~foreign_sources - ~(dir : Path.Build.t) - ~expander - ~requires - ~dir_contents + ~sctx + ~foreign_sources + ~(dir : Path.Build.t) + ~expander + ~requires + ~dir_contents = let includes = let h_files = diff --git a/src/dune_rules/foreign_sources.ml b/src/dune_rules/foreign_sources.ml index 8490dcf788d..565bf67c912 100644 --- a/src/dune_rules/foreign_sources.ml +++ b/src/dune_rules/foreign_sources.ml @@ -39,10 +39,10 @@ let valid_name language ~loc s = ;; let eval_foreign_stubs - foreign_stubs - (ctypes : Ctypes_field.t option) - ~dune_version - ~(sources : Foreign.Sources.Unresolved.t) + foreign_stubs + (ctypes : Ctypes_field.t option) + ~dune_version + ~(sources : Foreign.Sources.Unresolved.t) : Foreign.Sources.t = let multiple_sources_error ~name ~mode ~loc ~paths = @@ -139,7 +139,10 @@ let eval_foreign_stubs ~init:String.Map.empty ctypes.function_description ~f:(fun acc (fd : Ctypes_field.Function_description.t) -> - let loc = Loc.none (* TODO *) in + let loc = + Loc.none + (* TODO *) + in let fname = Ctypes_field.c_generated_functions_cout_c ctypes fd in let name = Filename.remove_extension fname in let path = diff --git a/src/dune_rules/format_rules.ml b/src/dune_rules/format_rules.ml index 1c3374c41b1..590acbc8a39 100644 --- a/src/dune_rules/format_rules.ml +++ b/src/dune_rules/format_rules.ml @@ -118,12 +118,12 @@ let format_action format ~ocamlformat_is_locked ~input ~output ~expander kind = ;; let gen_rules_output - sctx - (config : Format_config.t) - ~version - ~dialects - ~expander - ~output_dir + sctx + (config : Format_config.t) + ~version + ~dialects + ~expander + ~output_dir = assert (formatted_dir_basename = Path.Build.basename output_dir); let loc = Format_config.loc config in diff --git a/src/dune_rules/gen_meta.ml b/src/dune_rules/gen_meta.ml index d04fef2f695..4af20b59a17 100644 --- a/src/dune_rules/gen_meta.ml +++ b/src/dune_rules/gen_meta.ml @@ -111,10 +111,11 @@ let gen_lib pub_name lib ~version = List.concat [ version ; [ description desc; requires ~preds lib_deps ] - ; (if (match Lib.project lib with - | None -> true - | Some project -> Dune_project.dune_version project < (3, 17)) - || Lib_name.Set.is_empty lib_re_exports + ; (if + (match Lib.project lib with + | None -> true + | Some project -> Dune_project.dune_version project < (3, 17)) + || Lib_name.Set.is_empty lib_re_exports then [] else [ exports lib_re_exports ]) ; archives ~preds lib diff --git a/src/dune_rules/gen_rules.ml b/src/dune_rules/gen_rules.ml index 06dedbcbb62..df38a6e1da7 100644 --- a/src/dune_rules/gen_rules.ml +++ b/src/dune_rules/gen_rules.ml @@ -376,8 +376,9 @@ let gen_project_rules = | Some _ -> Memo.return () | None -> (match - if Dune_project.dune_version project >= (2, 8) - && Dune_project.generate_opam_files project + if + Dune_project.dune_version project >= (2, 8) + && Dune_project.generate_opam_files project then Dune_project.file project else None with @@ -587,12 +588,12 @@ let gen_rules ctx sctx ~dir components : Gen_rules.result Memo.t = | [] -> Subdir_set.all | _ -> Subdir_set.empty) (fun () -> - (* XXX the use of the super context is dubious here. We're using it to + (* XXX the use of the super context is dubious here. We're using it to take into account the env stanza. But really, these are internal libraries that are being compiled and user settings should be ignored. *) - let* sctx = sctx in - Jsoo_rules.setup_separate_compilation_rules sctx rest) + let* sctx = sctx in + Jsoo_rules.setup_separate_compilation_rules sctx rest) | "_doc" :: rest -> let* sctx = sctx in Odoc.gen_rules sctx rest ~dir @@ -606,8 +607,8 @@ let gen_rules ctx sctx ~dir components : Gen_rules.result Memo.t = | [] -> Subdir_set.all | _ -> Subdir_set.empty) (fun () -> - let* sctx = sctx in - Top_module.gen_rules sctx ~dir ~comps) + let* sctx = sctx in + Top_module.gen_rules sctx ~dir ~comps) | ".ppx" :: rest -> has_rules ~dir @@ -615,8 +616,8 @@ let gen_rules ctx sctx ~dir components : Gen_rules.result Memo.t = | [] -> Subdir_set.all | _ -> Subdir_set.empty) (fun () -> - let* sctx = sctx in - Pp_spec_rules.gen_rules sctx rest) + let* sctx = sctx in + Pp_spec_rules.gen_rules sctx rest) | [ ".dune" ] -> has_rules ~dir diff --git a/src/dune_rules/glob_files_expand.ml b/src/dune_rules/glob_files_expand.ml index 3044658ded8..463a5700c3b 100644 --- a/src/dune_rules/glob_files_expand.ml +++ b/src/dune_rules/glob_files_expand.ml @@ -8,9 +8,9 @@ open Memo.O "foo/bar/baz/qux". The descendants of a directory are that directory's subdirectories, and each of of their subdirectories, and so on ad infinitum. *) let get_descendants_of_relative_dir_relative_to_base_dir_local - ~base_dir - ~relative_dir - ~prefix + ~base_dir + ~relative_dir + ~prefix = let base_dir = Path.Build.drop_build_context_exn base_dir in let rec get_descendants_rec relative_dir prefix = diff --git a/src/dune_rules/import.ml b/src/dune_rules/import.ml index dbcf474a259..78bb8da1313 100644 --- a/src/dune_rules/import.ml +++ b/src/dune_rules/import.ml @@ -113,9 +113,9 @@ module Build_config = struct module Rules = Rules let make - ?(build_dir_only_sub_dirs = Rules.empty.build_dir_only_sub_dirs) - ?(directory_targets = Rules.empty.directory_targets) - rules + ?(build_dir_only_sub_dirs = Rules.empty.build_dir_only_sub_dirs) + ?(directory_targets = Rules.empty.directory_targets) + rules = let rules = { Rules.build_dir_only_sub_dirs; directory_targets; rules } in Gen_rules_result.rules_here rules diff --git a/src/dune_rules/include_stanza.ml b/src/dune_rules/include_stanza.ml index a947f87ca8b..d4e693c0ded 100644 --- a/src/dune_rules/include_stanza.ml +++ b/src/dune_rules/include_stanza.ml @@ -71,9 +71,9 @@ let error (type a) { current_file = (file : a); include_stack; path } = ;; let load_sexps - (type a) - ~context:({ current_file; include_stack; path } as context) - (loc, fn) + (type a) + ~context:({ current_file; include_stack; path } as context) + (loc, fn) = let module Path = (val path : Path with type t = a) in let include_stack = (loc, current_file) :: include_stack in diff --git a/src/dune_rules/inline_tests.ml b/src/dune_rules/inline_tests.ml index a6fe30ffad4..4905900807f 100644 --- a/src/dune_rules/inline_tests.ml +++ b/src/dune_rules/inline_tests.ml @@ -194,10 +194,11 @@ include Sub_system.Register_end_point (struct let+ jsoo_is_whole_program = Jsoo_rules.jsoo_is_whole_program sctx ~dir ~in_context:js_of_ocaml in - if List.exists modes ~f:(fun mode -> - match (mode : Mode_conf.t) with - | Jsoo mode -> Js_of_ocaml.Mode.Pair.select ~mode jsoo_is_whole_program - | Native | Best | Byte -> false) + if + List.exists modes ~f:(fun mode -> + match (mode : Mode_conf.t) with + | Jsoo mode -> Js_of_ocaml.Mode.Pair.select ~mode jsoo_is_whole_program + | Native | Best | Byte -> false) then Exe.Linkage.byte_for_jsoo :: l else l in diff --git a/src/dune_rules/install_entry.ml b/src/dune_rules/install_entry.ml index e976616e990..f208a1831b1 100644 --- a/src/dune_rules/install_entry.ml +++ b/src/dune_rules/install_entry.ml @@ -194,10 +194,10 @@ module Dir = struct type t = File_binding.Unexpanded.t Recursive_include.t let to_file_bindings_expanded - ts - ~expand - ~(dir : Path.Build.t) - ~relative_dst_path_starts_with_parent_error_when + ts + ~expand + ~(dir : Path.Build.t) + ~relative_dst_path_starts_with_parent_error_when = let* file_bindings_expanded = Memo.List.concat_map diff --git a/src/dune_rules/install_rules.ml b/src/dune_rules/install_rules.ml index d53e6b32b07..6189e951a01 100644 --- a/src/dune_rules/install_rules.ml +++ b/src/dune_rules/install_rules.ml @@ -169,12 +169,12 @@ end = struct ;; let lib_install_files - sctx - ~scope - ~dir_contents - ~dir - ~sub_dir:lib_subdir - (lib : Library.t) + sctx + ~scope + ~dir_contents + ~dir + ~sub_dir:lib_subdir + (lib : Library.t) = let loc = lib.buildable.loc in let ctx = Super_context.context sctx in @@ -945,9 +945,9 @@ let symlink_source_dir ~dir ~dst = ;; let symlink_installed_artifacts_to_build_install - (ctx : Build_context.t) - (entries : Install.Entry.Sourced.t list) - ~install_paths + (ctx : Build_context.t) + (entries : Install.Entry.Sourced.t list) + ~install_paths = let install_dir = Install.Context.dir ~context:ctx.name in Memo.parallel_map entries ~f:(fun (s : Install.Entry.Sourced.t) -> @@ -1094,7 +1094,8 @@ let package_deps (pkg : Package.t) files = rules_seen (Dep.Facts.paths ~expand_aliases:true res.facts |> Path.Set.to_list - |> (* if this file isn't in the build dir, it doesn't belong to any + |> + (* if this file isn't in the build dir, it doesn't belong to any package and it doesn't have dependencies that do *) List.filter_map ~f:Path.as_in_build_dir)) and loop_files rules_seen files = @@ -1286,10 +1287,11 @@ let gen_package_install_file_rules sctx (package : Package.t) = in if not (Package.allow_empty package) then - if List.for_all entries ~f:(fun (e : Install.Entry.Sourced.t) -> - match e.source with - | Dune -> true - | User _ -> false) + if + List.for_all entries ~f:(fun (e : Install.Entry.Sourced.t) -> + match e.source with + | Dune -> true + | User _ -> false) then ( let is_error = Dune_project.dune_version dune_project >= (3, 0) in User_warning.emit @@ -1330,16 +1332,16 @@ let memo = (Package.Name.to_string pkg)) "install-rules-and-pkg-entries" (fun (sctx, pkg) -> - Memo.return - (Scheme.Approximation - ( (let ctx = Super_context.context sctx in - Dir_set.subtree (Install.Context.dir ~context:(Context.name ctx))) - , Thunk - (fun () -> - let+ rules = - symlinked_entries sctx pkg >>| snd >>| Rules.of_rules >>| Rules.to_map - in - Scheme.Finite rules) ))) + Memo.return + (Scheme.Approximation + ( (let ctx = Super_context.context sctx in + Dir_set.subtree (Install.Context.dir ~context:(Context.name ctx))) + , Thunk + (fun () -> + let+ rules = + symlinked_entries sctx pkg >>| snd >>| Rules.of_rules >>| Rules.to_map + in + Scheme.Finite rules) ))) ;; let scheme sctx pkg = Memo.exec memo (sctx, pkg) @@ -1349,11 +1351,11 @@ let scheme_per_ctx_memo = ~input:(module Super_context.As_memo_key) "install-rule-scheme" (fun sctx -> - Dune_load.packages () - >>| Package.Name.Map.values - >>= Memo.parallel_map ~f:(fun pkg -> scheme sctx (Package.name pkg)) - >>| Scheme.all - >>= Scheme.evaluate ~union:Rules.Dir_rules.union) + Dune_load.packages () + >>| Package.Name.Map.values + >>= Memo.parallel_map ~f:(fun pkg -> scheme sctx (Package.name pkg)) + >>| Scheme.all + >>= Scheme.evaluate ~union:Rules.Dir_rules.union) ;; let symlink_rules sctx ~dir = diff --git a/src/dune_rules/jsoo/jsoo_rules.ml b/src/dune_rules/jsoo/jsoo_rules.ml index d54baee825d..f62c8c289c5 100644 --- a/src/dune_rules/jsoo/jsoo_rules.ml +++ b/src/dune_rules/jsoo/jsoo_rules.ml @@ -230,16 +230,16 @@ let js_of_ocaml_flags t ~dir ~mode (spec : Js_of_ocaml.Flags.Spec.t) = ;; let js_of_ocaml_rule - sctx - ~(mode : Js_of_ocaml.Mode.t) - ~sub_command - ~dir - ~(flags : _ Js_of_ocaml.Flags.t) - ~config - ~spec - ~target - ~sourcemap - ~directory_targets + sctx + ~(mode : Js_of_ocaml.Mode.t) + ~sub_command + ~dir + ~(flags : _ Js_of_ocaml.Flags.t) + ~config + ~spec + ~target + ~sourcemap + ~directory_targets = let open Action_builder.O in let jsoo = @@ -326,15 +326,15 @@ let standalone_runtime_rule ~mode cc ~runtime_files ~target ~flags ~sourcemap = ;; let exe_rule - ~mode - cc - ~linkall - ~runtime_files - ~src - ~target - ~directory_targets - ~flags - ~sourcemap + ~mode + cc + ~linkall + ~runtime_files + ~src + ~target + ~directory_targets + ~flags + ~sourcemap = let dir = Compilation_context.dir cc in let sctx = Compilation_context.super_context cc in @@ -408,17 +408,17 @@ let jsoo_archives ~mode ctx config lib = ;; let link_rule - ~mode - cc - ~runtime - ~target - ~directory_targets - ~obj_dir - cm - ~flags - ~linkall - ~link_time_code_gen - ~sourcemap + ~mode + cc + ~runtime + ~target + ~directory_targets + ~obj_dir + cm + ~flags + ~linkall + ~link_time_code_gen + ~sourcemap = let sctx = Compilation_context.super_context cc in let dir = Compilation_context.dir cc in @@ -597,10 +597,10 @@ let js_of_ocaml_sourcemap t ~dir ~mode = ;; let jsoo_enabled - ~eval - ~dir - ~(in_context : Js_of_ocaml.In_context.t Js_of_ocaml.Mode.Pair.t) - ~mode + ~eval + ~dir + ~(in_context : Js_of_ocaml.In_context.t Js_of_ocaml.Mode.Pair.t) + ~mode = match (Js_of_ocaml.Mode.Pair.select ~mode in_context).enabled_if with | Some enabled_if -> eval enabled_if @@ -619,10 +619,10 @@ let jsoo_enabled_modes ~expander ~dir ~in_context = ;; let jsoo_compilation_mode - t - ~dir - ~(in_context : Js_of_ocaml.In_context.t Js_of_ocaml.Mode.Pair.t) - ~mode + t + ~dir + ~(in_context : Js_of_ocaml.In_context.t Js_of_ocaml.Mode.Pair.t) + ~mode = match (Js_of_ocaml.Mode.Pair.select ~mode in_context).compilation_mode with | None -> js_of_ocaml_compilation_mode t ~dir ~mode @@ -641,16 +641,16 @@ let jsoo_is_whole_program t ~dir ~in_context = ;; let build_exe - cc - ~loc - ~in_context - ~src - ~(obj_dir : Path.Build.t Obj_dir.t) - ~(top_sorted_modules : Module.t list Action_builder.t) - ~promote - ~linkall - ~link_time_code_gen - ~jsoo_mode:mode + cc + ~loc + ~in_context + ~src + ~(obj_dir : Path.Build.t Obj_dir.t) + ~(top_sorted_modules : Module.t list Action_builder.t) + ~promote + ~linkall + ~link_time_code_gen + ~jsoo_mode:mode = let sctx = Compilation_context.super_context cc in let dir = Compilation_context.dir cc in diff --git a/src/dune_rules/lib.ml b/src/dune_rules/lib.ml index 041522a9b5c..90b3567be4b 100644 --- a/src/dune_rules/lib.ml +++ b/src/dune_rules/lib.ml @@ -1471,11 +1471,11 @@ end = struct ;; let add_pp_runtime_deps - db - { Resolved.resolved; selects; re_exports } - ~private_deps - ~pps - ~dune_version + db + { Resolved.resolved; selects; re_exports } + ~private_deps + ~pps + ~dune_version : Resolved.t Memo.t = let { runtime_deps; pps } = pp_deps db pps ~dune_version ~private_deps in @@ -2032,13 +2032,13 @@ module DB = struct ;; let resolve_user_written_deps - t - targets - ~allow_overlaps - ~forbidden_libraries - deps - ~pps - ~dune_version + t + targets + ~allow_overlaps + ~forbidden_libraries + deps + ~pps + ~dune_version = let resolved = Memo.lazy_ (fun () -> @@ -2072,10 +2072,10 @@ module DB = struct in Resolve.Memo.push_stack_frame (fun () -> - Resolve_names.linking_closure_with_overlap_checks - (Option.some_if (not allow_overlaps) t) - ~forbidden_libraries - res) + Resolve_names.linking_closure_with_overlap_checks + (Option.some_if (not allow_overlaps) t) + ~forbidden_libraries + res) ~human_readable_description:(fun () -> match targets with | `Melange_emit name -> Pp.textf "melange target %s" name @@ -2137,12 +2137,12 @@ module DB = struct end let to_dune_lib - ({ info; _ } as lib) - ~modules - ~foreign_objects - ~melange_runtime_deps - ~public_headers - ~dir + ({ info; _ } as lib) + ~modules + ~foreign_objects + ~melange_runtime_deps + ~public_headers + ~dir : Dune_package.Lib.t Resolve.Memo.t = let loc = Lib_info.loc info in diff --git a/src/dune_rules/lib_flags.ml b/src/dune_rules/lib_flags.ml index c6e32600d5f..a4b156eae4f 100644 --- a/src/dune_rules/lib_flags.ml +++ b/src/dune_rules/lib_flags.ml @@ -5,10 +5,10 @@ module Link_params = struct type t = { include_dirs : Path.t list ; deps : Path.t list - (* List of files that will be read by the compiler at link time and + (* List of files that will be read by the compiler at link time and appear directly on the command line *) ; hidden_deps : Path.t list - (* List of files that will be read by the compiler at link time but do + (* List of files that will be read by the compiler at link time but do not appear on the command line *) } @@ -249,36 +249,36 @@ module Lib_and_module = struct (let+ l = Action_builder.all (List.map ts ~f:(function - | Lib t -> - let+ p = - Action_builder.of_memo (Link_params.get sctx t mode lib_config) - in - Command.Args.S - (Deps p.deps - :: Hidden_deps (Dep.Set.of_files p.hidden_deps) - :: List.map p.include_dirs ~f:(fun dir -> - Command.Args.S [ A "-I"; Path dir ])) - | Module (obj_dir, m) -> - Action_builder.return - (Command.Args.S - (Dep - (Obj_dir.Module.cm_file_exn - obj_dir - m - ~kind:(Ocaml (Mode.cm_kind (Link_mode.mode mode)))) - :: - (match mode with - | Native -> - [ Command.Args.Hidden_deps - (Dep.Set.of_files - [ Obj_dir.Module.o_file_exn - obj_dir - m - ~ext_obj:lib_config.ext_obj - ]) - ] - | Byte | Byte_for_jsoo | Byte_with_stubs_statically_linked_in -> - []))))) + | Lib t -> + let+ p = + Action_builder.of_memo (Link_params.get sctx t mode lib_config) + in + Command.Args.S + (Deps p.deps + :: Hidden_deps (Dep.Set.of_files p.hidden_deps) + :: List.map p.include_dirs ~f:(fun dir -> + Command.Args.S [ A "-I"; Path dir ])) + | Module (obj_dir, m) -> + Action_builder.return + (Command.Args.S + (Dep + (Obj_dir.Module.cm_file_exn + obj_dir + m + ~kind:(Ocaml (Mode.cm_kind (Link_mode.mode mode)))) + :: + (match mode with + | Native -> + [ Command.Args.Hidden_deps + (Dep.Set.of_files + [ Obj_dir.Module.o_file_exn + obj_dir + m + ~ext_obj:lib_config.ext_obj + ]) + ] + | Byte | Byte_for_jsoo | Byte_with_stubs_statically_linked_in -> + []))))) in Command.Args.S l) ;; diff --git a/src/dune_rules/lib_info.ml b/src/dune_rules/lib_info.ml index 6744ee0a70c..5cd52c04f5f 100644 --- a/src/dune_rules/lib_info.ml +++ b/src/dune_rules/lib_info.ml @@ -394,45 +394,45 @@ let user_written_deps t = ;; let create - ~loc - ~path_kind - ~name - ~lib_id - ~kind - ~status - ~src_dir - ~orig_src_dir - ~obj_dir - ~version - ~synopsis - ~main_module_name - ~sub_systems - ~requires - ~foreign_objects - ~public_headers - ~plugins - ~archives - ~ppx_runtime_deps - ~foreign_archives - ~native_archives - ~foreign_dll_files - ~jsoo_runtime - ~wasmoo_runtime - ~preprocess - ~enabled - ~virtual_deps - ~dune_version - ~virtual_ - ~entry_modules - ~implements - ~default_implementation - ~modes - ~modules - ~wrapped - ~special_builtin_support - ~exit_module - ~instrumentation_backend - ~melange_runtime_deps + ~loc + ~path_kind + ~name + ~lib_id + ~kind + ~status + ~src_dir + ~orig_src_dir + ~obj_dir + ~version + ~synopsis + ~main_module_name + ~sub_systems + ~requires + ~foreign_objects + ~public_headers + ~plugins + ~archives + ~ppx_runtime_deps + ~foreign_archives + ~native_archives + ~foreign_dll_files + ~jsoo_runtime + ~wasmoo_runtime + ~preprocess + ~enabled + ~virtual_deps + ~dune_version + ~virtual_ + ~entry_modules + ~implements + ~default_implementation + ~modes + ~modules + ~wrapped + ~special_builtin_support + ~exit_module + ~instrumentation_backend + ~melange_runtime_deps = { loc ; name @@ -527,47 +527,47 @@ let as_local_exn = ;; let to_dyn - path - { loc - ; path_kind = _ - ; name - ; lib_id - ; kind - ; status - ; src_dir - ; orig_src_dir - ; obj_dir - ; version - ; synopsis - ; requires - ; main_module_name - ; foreign_objects - ; public_headers - ; plugins - ; archives - ; ppx_runtime_deps - ; foreign_archives - ; native_archives - ; foreign_dll_files - ; jsoo_runtime - ; wasmoo_runtime - ; preprocess = _ - ; enabled = _ - ; virtual_deps - ; dune_version - ; sub_systems - ; virtual_ - ; implements - ; default_implementation - ; modes - ; modules - ; wrapped - ; special_builtin_support - ; exit_module - ; instrumentation_backend - ; melange_runtime_deps - ; entry_modules - } + path + { loc + ; path_kind = _ + ; name + ; lib_id + ; kind + ; status + ; src_dir + ; orig_src_dir + ; obj_dir + ; version + ; synopsis + ; requires + ; main_module_name + ; foreign_objects + ; public_headers + ; plugins + ; archives + ; ppx_runtime_deps + ; foreign_archives + ; native_archives + ; foreign_dll_files + ; jsoo_runtime + ; wasmoo_runtime + ; preprocess = _ + ; enabled = _ + ; virtual_deps + ; dune_version + ; sub_systems + ; virtual_ + ; implements + ; default_implementation + ; modes + ; modules + ; wrapped + ; special_builtin_support + ; exit_module + ; instrumentation_backend + ; melange_runtime_deps + ; entry_modules + } = let open Dyn in let snd f (_, x) = f x in @@ -623,18 +623,18 @@ let package t = ;; let for_dune_package - t - ~name - ~ppx_runtime_deps - ~requires - ~foreign_objects - ~obj_dir - ~implements - ~default_implementation - ~sub_systems - ~melange_runtime_deps - ~public_headers - ~modules + t + ~name + ~ppx_runtime_deps + ~requires + ~foreign_objects + ~obj_dir + ~implements + ~default_implementation + ~sub_systems + ~melange_runtime_deps + ~public_headers + ~modules = let foreign_objects = Source.External foreign_objects in let orig_src_dir = diff --git a/src/dune_rules/lib_rules.ml b/src/dune_rules/lib_rules.ml index 6cbc49b8053..f1ad029858e 100644 --- a/src/dune_rules/lib_rules.ml +++ b/src/dune_rules/lib_rules.ml @@ -13,14 +13,14 @@ let msvc_hack_cclibs = (* Build an OCaml library. *) let build_lib - (lib : Library.t) - ~native_archives - ~sctx - ~expander - ~flags - ~dir - ~mode - ~cm_files + (lib : Library.t) + ~native_archives + ~sctx + ~expander + ~flags + ~dir + ~mode + ~cm_files = let ctx = Super_context.context sctx in let* ocaml = Context.ocaml ctx in @@ -152,14 +152,14 @@ let gen_wrapped_compat_modules (lib : Library.t) cctx = (* Rules for building static and dynamic libraries using [ocamlmklib]. *) let ocamlmklib - ~loc - ~c_library_flags - ~sctx - ~dir - ~o_files - ~archive_name - ~stubs_mode - ~build_targets_together + ~loc + ~c_library_flags + ~sctx + ~dir + ~o_files + ~archive_name + ~stubs_mode + ~build_targets_together = let ctx = Super_context.context sctx in let* ocaml = Context.ocaml ctx in @@ -209,8 +209,8 @@ let ocamlmklib unless dynamically linked foreign archives are disabled. *) Context.dynamically_linked_foreign_archives ctx >>| (function - | true -> [ static_target; dynamic_target ] - | false -> [ static_target ]) + | true -> [ static_target; dynamic_target ] + | false -> [ static_target ]) >>= build ~sandbox:Sandbox_config.no_special_requirements ~custom:false else (* Build the static target only by passing the [-custom] flag. *) @@ -331,9 +331,10 @@ let build_stubs lib ~cctx ~dir ~expander ~requires ~dir_contents ~vlib_stubs_o_f in let lib_o_files_for_all_modes = Mode.Map.Multi.for_all_modes o_files in let for_all_modes = List.rev_append vlib_stubs_o_files lib_o_files_for_all_modes in - if Mode.Dict.Set.to_list modes.ocaml - |> List.for_all ~f:(fun mode -> - List.is_empty @@ Mode.Map.Multi.for_only ~and_all:false o_files mode) + if + Mode.Dict.Set.to_list modes.ocaml + |> List.for_all ~f:(fun mode -> + List.is_empty @@ Mode.Map.Multi.for_only ~and_all:false o_files mode) then ( (* if stubs are not mode dependent *) let o_files = for_all_modes in @@ -553,13 +554,13 @@ let cctx (lib : Library.t) ~sctx ~source_modules ~dir ~expander ~scope ~compile_ ;; let library_rules - (lib : Library.t) - ~local_lib - ~cctx - ~source_modules - ~dir_contents - ~compile_info - ~ctx_dir + (lib : Library.t) + ~local_lib + ~cctx + ~source_modules + ~dir_contents + ~compile_info + ~ctx_dir = let source_modules = Modules.fold_user_written source_modules ~init:[] ~f:(fun m acc -> m :: acc) @@ -613,14 +614,14 @@ let library_rules Memo.when_ (Library.has_foreign lib || List.is_non_empty vlib_stubs_o_files) (fun () -> - build_stubs - lib - ~cctx - ~dir - ~expander - ~requires:requires_compile - ~dir_contents - ~vlib_stubs_o_files) + build_stubs + lib + ~cctx + ~dir + ~expander + ~requires:requires_compile + ~dir_contents + ~vlib_stubs_o_files) and+ () = Odoc.setup_private_library_doc_alias sctx ~scope ~dir:ctx_dir lib and+ () = Odoc.setup_library_odoc_rules cctx local_lib and+ () = diff --git a/src/dune_rules/main.ml b/src/dune_rules/main.ml index 5d83235ea35..d48c56d0be6 100644 --- a/src/dune_rules/main.ml +++ b/src/dune_rules/main.ml @@ -46,11 +46,11 @@ let execution_parameters = ;; let init - ~stats - ~sandboxing_preference - ~cache_config - ~(cache_debug_flags : Dune_engine.Cache_debug_flags.t) - () + ~stats + ~sandboxing_preference + ~cache_config + ~(cache_debug_flags : Dune_engine.Cache_debug_flags.t) + () : unit = let promote_source ~chmod ~delete_dst_if_it_is_a_directory ~src ~dst = diff --git a/src/dune_rules/melange/melange_rules.ml b/src/dune_rules/melange/melange_rules.ml index dff2d385c02..c1ee0e15e09 100644 --- a/src/dune_rules/melange/melange_rules.ml +++ b/src/dune_rules/melange/melange_rules.ml @@ -185,17 +185,17 @@ let js_targets_of_libs ~sctx ~scope ~module_systems ~target_dir libs = ;; let build_js - ~loc - ~dir - ~pkg_name - ~mode - ~module_systems - ~output - ~obj_dir - ~sctx - ~includes - ~local_modules_and_obj_dir - m + ~loc + ~dir + ~pkg_name + ~mode + ~module_systems + ~output + ~obj_dir + ~sctx + ~includes + ~local_modules_and_obj_dir + m = let* compiler = Melange_binary.melc sctx ~loc:(Some loc) ~dir in Memo.parallel_iter module_systems ~f:(fun (module_system, js_ext) -> @@ -260,12 +260,12 @@ let add_deps_to_aliases ?(alias = Melange_stanzas.Emit.implicit_alias) ~dir deps ;; let setup_emit_cmj_rules - ~sctx - ~dir - ~scope - ~expander - ~dir_contents - (mel : Melange_stanzas.Emit.t) + ~sctx + ~dir + ~scope + ~expander + ~dir_contents + (mel : Melange_stanzas.Emit.t) = let* compile_info = compile_info ~scope mel in let ctx = Super_context.context sctx in @@ -451,14 +451,14 @@ let modules_for_js_and_obj_dir ~sctx ~dir_contents ~scope (mel : Melange_stanzas ;; let setup_entries_js - ~sctx - ~dir - ~dir_contents - ~scope - ~compile_info - ~target_dir - ~mode - (mel : Melange_stanzas.Emit.t) + ~sctx + ~dir + ~dir_contents + ~scope + ~compile_info + ~target_dir + ~mode + (mel : Melange_stanzas.Emit.t) = let* local_modules, modules_for_js, local_obj_dir = modules_for_js_and_obj_dir ~sctx ~dir_contents ~scope mel @@ -614,15 +614,15 @@ let setup_js_rules_libraries = ;; let setup_js_rules_libraries_and_entries - ~dir_contents - ~dir - ~scope - ~sctx - ~compile_info - ~requires_link - ~mode - ~target_dir - mel + ~dir_contents + ~dir + ~scope + ~sctx + ~compile_info + ~requires_link + ~mode + ~target_dir + mel = let+ () = setup_js_rules_libraries ~dir ~scope ~target_dir ~sctx ~requires_link ~mode mel diff --git a/src/dune_rules/menhir/menhir_rules.ml b/src/dune_rules/menhir/menhir_rules.ml index d07ca7afa2d..1dc41f2cef2 100644 --- a/src/dune_rules/menhir/menhir_rules.ml +++ b/src/dune_rules/menhir/menhir_rules.ml @@ -216,15 +216,16 @@ module Run (P : PARAMS) = struct should not be explicitly added to the list of Menhir flags." ] | Some text -> - if List.mem - ~equal:String.equal - [ "--depend" - ; "--raw-depend" - ; "--infer" - ; "--infer-write-query" - ; "--infer-read-reply" - ] - text + if + List.mem + ~equal:String.equal + [ "--depend" + ; "--raw-depend" + ; "--infer" + ; "--infer-write-query" + ; "--infer-read-reply" + ] + text then User_error.raise ~loc:(String_with_vars.loc sw) diff --git a/src/dune_rules/merlin/merlin.ml b/src/dune_rules/merlin/merlin.ml index d685d60ccbe..2f0fb6fd314 100644 --- a/src/dune_rules/merlin/merlin.ml +++ b/src/dune_rules/merlin/merlin.ml @@ -64,16 +64,16 @@ module Processed = struct } let dyn_of_config - { stdlib_dir - ; source_root - ; obj_dirs - ; src_dirs - ; hidden_obj_dirs - ; hidden_src_dirs - ; flags - ; extensions - ; indexes - } + { stdlib_dir + ; source_root + ; obj_dirs + ; src_dirs + ; hidden_obj_dirs + ; hidden_src_dirs + ; flags + ; extensions + ; indexes + } = let open Dyn in record @@ -178,20 +178,20 @@ module Processed = struct ;; let to_sexp - ~unit_name - ~opens - ~pp - ~reader - { stdlib_dir - ; source_root - ; obj_dirs - ; src_dirs - ; hidden_obj_dirs - ; hidden_src_dirs - ; flags - ; extensions - ; indexes - } + ~unit_name + ~opens + ~pp + ~reader + { stdlib_dir + ; source_root + ; obj_dirs + ; src_dirs + ; hidden_obj_dirs + ; hidden_src_dirs + ; flags + ; extensions + ; indexes + } = let make_directive tag value = Sexp.List [ Atom tag; value ] in let make_directive_of_path tag path = @@ -280,16 +280,16 @@ module Processed = struct ;; let to_dot_merlin - stdlib_dir - source_root - pp_configs - flags - obj_dirs - src_dirs - hidden_obj_dirs - hidden_src_dirs - extensions - indexes + stdlib_dir + source_root + pp_configs + flags + obj_dirs + src_dirs + hidden_obj_dirs + hidden_src_dirs + extensions + indexes = let b = Buffer.create 256 in let printf = Printf.bprintf b in @@ -482,17 +482,17 @@ module Unprocessed = struct } let make - ~requires_compile - ~requires_hidden - ~stdlib_dir - ~flags - ~preprocess - ~libname - ~modules - ~obj_dir - ~dialects - ~ident - ~modes + ~requires_compile + ~requires_hidden + ~stdlib_dir + ~flags + ~preprocess + ~libname + ~modules + ~obj_dir + ~dialects + ~ident + ~modes = (* Merlin shouldn't cause the build to fail, so we just ignore errors *) let mode = @@ -632,25 +632,25 @@ module Unprocessed = struct ;; let process - ({ modules - ; ident = _ - ; config = - { stdlib_dir - ; extensions - ; readers - ; flags - ; objs_dirs - ; requires_compile - ; requires_hidden - ; preprocess = _ - ; libname = _ - ; mode - } - } as t) - sctx - ~dir - ~more_src_dirs - ~expander + ({ modules + ; ident = _ + ; config = + { stdlib_dir + ; extensions + ; readers + ; flags + ; objs_dirs + ; requires_compile + ; requires_hidden + ; preprocess = _ + ; libname = _ + ; mode + } + } as t) + sctx + ~dir + ~more_src_dirs + ~expander = let open Action_builder.O in let+ config = diff --git a/src/dune_rules/ml_sources.ml b/src/dune_rules/ml_sources.ml index bb2a061a802..441910be32f 100644 --- a/src/dune_rules/ml_sources.ml +++ b/src/dune_rules/ml_sources.ml @@ -345,14 +345,14 @@ let virtual_modules ~lookup_vlib ~libs vlib = ;; let make_lib_modules - ~expander - ~dir - ~libs - ~lookup_vlib - ~(lib : Library.t) - ~modules - ~include_subdirs:(loc_include_subdirs, (include_subdirs : Include_subdirs.t)) - ~version + ~expander + ~dir + ~libs + ~lookup_vlib + ~(lib : Library.t) + ~modules + ~include_subdirs:(loc_include_subdirs, (include_subdirs : Include_subdirs.t)) + ~version = let open Resolve.Memo.O in let* kind, main_module_name, wrapped = @@ -555,16 +555,16 @@ let modules_of_stanzas = ;; let make - dune_file - ~expander - ~dir - ~libs - ~project - ~lib_config - ~loc - ~lookup_vlib - ~include_subdirs:(loc_include_subdirs, (include_subdirs : Include_subdirs.t)) - ~dirs + dune_file + ~expander + ~dir + ~libs + ~project + ~lib_config + ~loc + ~lookup_vlib + ~include_subdirs:(loc_include_subdirs, (include_subdirs : Include_subdirs.t)) + ~dirs = let+ modules_of_stanzas = let modules = diff --git a/src/dune_rules/module.ml b/src/dune_rules/module.ml index 6ea97e25ad9..d17cb796ab5 100644 --- a/src/dune_rules/module.ml +++ b/src/dune_rules/module.ml @@ -4,7 +4,7 @@ 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 + (* 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 } diff --git a/src/dune_rules/module_compilation.ml b/src/dune_rules/module_compilation.ml index 3b469b24ae5..fae4cd3203e 100644 --- a/src/dune_rules/module_compilation.ml +++ b/src/dune_rules/module_compilation.ml @@ -39,13 +39,13 @@ let copy_interface ~sctx ~dir ~obj_dir ~cm_kind m = (Module.visibility m <> Visibility.Private && Obj_dir.need_dedicated_public_dir obj_dir) (fun () -> - let cmi_kind = Lib_mode.Cm_kind.cmi cm_kind in - Super_context.add_rule - sctx - ~dir - (Action_builder.symlink - ~src:(Path.build (Obj_dir.Module.cm_file_exn obj_dir m ~kind:cmi_kind)) - ~dst:(Obj_dir.Module.cm_public_file_exn obj_dir m ~kind:cmi_kind))) + let cmi_kind = Lib_mode.Cm_kind.cmi cm_kind in + Super_context.add_rule + sctx + ~dir + (Action_builder.symlink + ~src:(Path.build (Obj_dir.Module.cm_file_exn obj_dir m ~kind:cmi_kind)) + ~dst:(Obj_dir.Module.cm_public_file_exn obj_dir m ~kind:cmi_kind))) ;; let melange_args (cctx : Compilation_context.t) (cm_kind : Lib_mode.Cm_kind.t) module_ = @@ -84,12 +84,12 @@ let melange_args (cctx : Compilation_context.t) (cm_kind : Lib_mode.Cm_kind.t) m ;; let build_cm - cctx - ~force_write_cmi - ~precompiled_cmi - ~cm_kind - (m : Module.t) - ~(phase : Fdo.phase option) + cctx + ~force_write_cmi + ~precompiled_cmi + ~cm_kind + (m : Module.t) + ~(phase : Fdo.phase option) = if force_write_cmi && precompiled_cmi then Code_error.raise "force_read_cmi and precompiled_cmi are mutually exclusive" []; diff --git a/src/dune_rules/modules_field_evaluator.ml b/src/dune_rules/modules_field_evaluator.ml index 34f1603de0c..2982b0e64f3 100644 --- a/src/dune_rules/modules_field_evaluator.ml +++ b/src/dune_rules/modules_field_evaluator.ml @@ -100,12 +100,12 @@ type errors = } let find_errors - ~modules - ~intf_only - ~virtual_modules - ~private_modules - ~existing_virtual_modules - ~allow_new_public_modules + ~modules + ~intf_only + ~virtual_modules + ~private_modules + ~existing_virtual_modules + ~allow_new_public_modules = let all = (* We expect that [modules] is big and all the other ones are small, that's @@ -171,16 +171,16 @@ let find_errors ;; let check_invalid_module_listing - ~stanza_loc - ~modules_without_implementation - ~intf_only - ~modules - ~virtual_modules - ~private_modules - ~existing_virtual_modules - ~allow_new_public_modules - ~is_vendored - ~version + ~stanza_loc + ~modules_without_implementation + ~intf_only + ~modules + ~virtual_modules + ~private_modules + ~existing_virtual_modules + ~allow_new_public_modules + ~is_vendored + ~version = let { errors; unimplemented_virt_modules } = find_errors @@ -191,8 +191,9 @@ let check_invalid_module_listing ~existing_virtual_modules ~allow_new_public_modules in - if List.is_non_empty errors - || not (Module_name.Path.Set.is_empty unimplemented_virt_modules) + if + List.is_non_empty errors + || not (Module_name.Path.Set.is_empty unimplemented_virt_modules) then ( let get kind = List.filter_map errors ~f:(fun (k, loc, m) -> Option.some_if (kind = k) (loc, m)) @@ -326,19 +327,19 @@ let check_invalid_module_listing ;; let eval - ~expander - ~modules:(all_modules : Module.Source.t Module_trie.t) - ~stanza_loc - ~private_modules - ~kind - ~src_dir - ~is_vendored - ~version - { Stanza_common.Modules_settings.modules = _ - ; root_module - ; modules_without_implementation - } - modules + ~expander + ~modules:(all_modules : Module.Source.t Module_trie.t) + ~stanza_loc + ~private_modules + ~kind + ~src_dir + ~is_vendored + ~version + { Stanza_common.Modules_settings.modules = _ + ; root_module + ; modules_without_implementation + } + modules = (* Fake modules are modules that do not exist but it doesn't matter because they are only removed from a set (for jbuild file compatibility) *) @@ -398,14 +399,14 @@ let eval ;; let eval - ~expander - ~modules:(all_modules : Module.Source.t Module_trie.t) - ~stanza_loc - ~private_modules - ~kind - ~src_dir - ~version - (settings : Stanza_common.Modules_settings.t) + ~expander + ~modules:(all_modules : Module.Source.t Module_trie.t) + ~stanza_loc + ~private_modules + ~kind + ~src_dir + ~version + (settings : Stanza_common.Modules_settings.t) = Memo.push_stack_frame ~human_readable_description:(fun () -> Pp.textf "(modules) field at %s" (Loc.to_file_colon_line stanza_loc)) diff --git a/src/dune_rules/obj_dir.ml b/src/dune_rules/obj_dir.ml index 9c54eabd31c..e952d8d4b45 100644 --- a/src/dune_rules/obj_dir.ml +++ b/src/dune_rules/obj_dir.ml @@ -65,7 +65,12 @@ module External = struct ;; let to_dyn - { public_dir; private_dir; public_cmi_ocaml_dir; melange_dir; public_cmi_melange_dir } + { public_dir + ; private_dir + ; public_cmi_ocaml_dir + ; melange_dir + ; public_cmi_melange_dir + } = let open Dyn in record @@ -89,12 +94,12 @@ module External = struct ;; let encode - { public_dir - ; private_dir - ; public_cmi_ocaml_dir - ; public_cmi_melange_dir - ; melange_dir = _ - } + { public_dir + ; private_dir + ; public_cmi_ocaml_dir + ; public_cmi_melange_dir + ; melange_dir = _ + } = let open Dune_lang.Encoder in let extract d = @@ -142,12 +147,12 @@ module External = struct let all_obj_dirs t ~mode:_ = [ t.public_dir ] let all_cmis - { public_dir - ; melange_dir = _ - ; private_dir - ; public_cmi_ocaml_dir - ; public_cmi_melange_dir = _ - } + { public_dir + ; melange_dir = _ + ; private_dir + ; public_cmi_ocaml_dir + ; public_cmi_melange_dir = _ + } = List.filter_opt [ Some public_dir @@ -183,16 +188,16 @@ module Local = struct let equal : t -> t -> bool = Poly.equal let to_dyn - { dir - ; obj_dir - ; native_dir - ; byte_dir - ; jsoo_dir - ; melange_dir - ; public_cmi_ocaml_dir - ; public_cmi_melange_dir - ; private_lib - } + { dir + ; obj_dir + ; native_dir + ; byte_dir + ; jsoo_dir + ; melange_dir + ; public_cmi_ocaml_dir + ; public_cmi_melange_dir + ; private_lib + } = let open Dyn in record @@ -209,15 +214,15 @@ module Local = struct ;; let make - ~dir - ~obj_dir - ~native_dir - ~byte_dir - ~jsoo_dir - ~melange_dir - ~public_cmi_ocaml_dir - ~public_cmi_melange_dir - ~private_lib + ~dir + ~obj_dir + ~native_dir + ~byte_dir + ~jsoo_dir + ~melange_dir + ~public_cmi_ocaml_dir + ~public_cmi_melange_dir + ~private_lib = { dir ; obj_dir diff --git a/src/dune_rules/ocaml_stdlib.mli b/src/dune_rules/ocaml_stdlib.mli index 82c3b75a602..1d02a438c2d 100644 --- a/src/dune_rules/ocaml_stdlib.mli +++ b/src/dune_rules/ocaml_stdlib.mli @@ -8,12 +8,12 @@ open Import type t = private { modules_before_stdlib : Module_name.Set.t - (** Modules that the Stdlib module depend on. *) + (** Modules that the Stdlib module depend on. *) ; exit_module : Module_name.t option - (** Modules that are implicitly added by the compiler at the end when + (** Modules that are implicitly added by the compiler at the end when linking an executable *) ; internal_modules : Predicate_lang.Glob.t - (** Module names that are hardcoded in the compiler and so cannot be + (** Module names that are hardcoded in the compiler and so cannot be wrapped *) ; loc : Loc.t } diff --git a/src/dune_rules/ocamldep.ml b/src/dune_rules/ocamldep.ml index 61749e7ad97..c4a2b78ff7d 100644 --- a/src/dune_rules/ocamldep.ml +++ b/src/dune_rules/ocamldep.ml @@ -28,10 +28,10 @@ module Merge_files_into = struct ;; let encode - (type src dst) - ((sources, extras, target) : (src, dst) t) - (input : src -> Sexp.t) - (output : dst -> Sexp.t) + (type src dst) + ((sources, extras, target) : (src, dst) t) + (input : src -> Sexp.t) + (output : dst -> Sexp.t) : Sexp.t = List @@ -125,9 +125,9 @@ let transitive_deps = ;; let deps_of - ({ sandbox; modules; sctx; dir; obj_dir; vimpl = _; stdlib = _ } as md) - ~ml_kind - unit + ({ sandbox; modules; sctx; dir; obj_dir; vimpl = _; stdlib = _ } as md) + ~ml_kind + unit = let source = Option.value_exn (Module.source unit ~ml_kind) in let dep = Obj_dir.Module.dep obj_dir in diff --git a/src/dune_rules/odoc.ml b/src/dune_rules/odoc.ml index d52f92ea8bd..01927de1e89 100644 --- a/src/dune_rules/odoc.ml +++ b/src/dune_rules/odoc.ml @@ -304,13 +304,13 @@ let module_deps (m : Module.t) ~obj_dir ~(dep_graphs : Dep_graph.Ml_kind.t) = ;; let compile_module - sctx - ~obj_dir - (m : Module.t) - ~includes:(file_deps, iflags) - ~dep_graphs - ~pkg_or_lnu - ~mode + sctx + ~obj_dir + (m : Module.t) + ~includes:(file_deps, iflags) + ~dep_graphs + ~pkg_or_lnu + ~mode = let odoc_file = Obj_dir.Module.odoc obj_dir m in let+ () = @@ -920,21 +920,21 @@ let package_mlds = "package-mlds" ~input:(module Super_context.As_memo_key.And_package_name) (fun (sctx, pkg) -> - Rules.collect (fun () -> - let* mlds = Packages.mlds sctx pkg in - let mlds = check_mlds_no_dupes ~pkg ~mlds in - let ctx = Super_context.context sctx in - if Filename.Map.mem mlds "index" - then Memo.return mlds - else ( - let gen_mld = Paths.gen_mld_dir ctx pkg ++ "index.mld" in - let* entry_modules = entry_modules sctx ~pkg in - let+ () = - add_rule - sctx - (Action_builder.write_file gen_mld (default_index ~pkg entry_modules)) - in - Filename.Map.set mlds "index" gen_mld))) + Rules.collect (fun () -> + let* mlds = Packages.mlds sctx pkg in + let mlds = check_mlds_no_dupes ~pkg ~mlds in + let ctx = Super_context.context sctx in + if Filename.Map.mem mlds "index" + then Memo.return mlds + else ( + let gen_mld = Paths.gen_mld_dir ctx pkg ++ "index.mld" in + let* entry_modules = entry_modules sctx ~pkg in + let+ () = + add_rule + sctx + (Action_builder.write_file gen_mld (default_index ~pkg entry_modules)) + in + Filename.Map.set mlds "index" gen_mld))) in fun sctx ~pkg -> Memo.exec memo (sctx, pkg) ;; diff --git a/src/dune_rules/odoc_new.ml b/src/dune_rules/odoc_new.ml index 7875785dbb9..1491b0cb777 100644 --- a/src/dune_rules/odoc_new.ml +++ b/src/dune_rules/odoc_new.ml @@ -847,15 +847,15 @@ let index_dep index = ;; let compile_module - sctx - all - ~artifact:a - ~quiet - ~requires - ~package - ~module_deps - ~parent_opt - ~indices + sctx + all + ~artifact:a + ~quiet + ~requires + ~package + ~module_deps + ~parent_opt + ~indices = let odoc_file = Artifact.odoc_file a in let ctx = Super_context.context sctx in @@ -1173,9 +1173,9 @@ let modules_of_dir d : (Module_name.t * (Path.t * [ `Cmti | `Cmt | `Cmi ])) list to be documented - packages, fallback dirs, libraries (both private and those in packages) *) let fallback_artifacts - ctx - (location : Dune_package.External_location.t) - (libs : Lib.t Lib_name.Map.t) + ctx + (location : Dune_package.External_location.t) + (libs : Lib.t Lib_name.Map.t) = let* maps = Valid.libs_maps ctx ~all:true in match Index.of_external_loc maps location with @@ -1242,12 +1242,12 @@ let ext_package_mlds (ctx : Context.t) (pkg : Package.Name.t) = let doc_path = Section.Map.find_exn dpkg.sections Doc in Some (List.filter_map fs ~f:(function - | `File, dst -> - let str = Install.Entry.Dst.to_string dst in - if Filename.check_suffix str ".mld" - then Some (Path.relative doc_path str) - else None - | _ -> None)) + | `File, dst -> + let str = Install.Entry.Dst.to_string dst in + if Filename.check_suffix str ".mld" + then Some (Path.relative doc_path str) + else None + | _ -> None)) | _ -> None) |> List.concat ;; @@ -1721,19 +1721,19 @@ let toplevel_index_contents t = output_indices "Local Packages" (List.filter_map sorted ~f:(function - | [ x; Index.Top_dir Local_packages ] -> Some x - | _ -> None)); + | [ x; Index.Top_dir Local_packages ] -> Some x + | _ -> None)); output_indices "Switch-installed packages" (List.filter_map sorted ~f:(function - | [ x; Index.Top_dir (Relative_to_findlib _) ] -> Some x - | [ (Index.Top_dir Relative_to_stdlib as x) ] -> Some x - | _ -> None)); + | [ x; Index.Top_dir (Relative_to_findlib _) ] -> Some x + | [ (Index.Top_dir Relative_to_stdlib as x) ] -> Some x + | _ -> None)); output_indices "Private libraries" (List.filter_map sorted ~f:(function - | [ (Index.Private_lib _ as x) ] -> Some x - | _ -> None)); + | [ (Index.Private_lib _ as x) ] -> Some x + | _ -> None)); Buffer.contents b ;; diff --git a/src/dune_rules/only_packages.mli b/src/dune_rules/only_packages.mli index 6c6b8759157..01ee36ced6a 100644 --- a/src/dune_rules/only_packages.mli +++ b/src/dune_rules/only_packages.mli @@ -8,7 +8,7 @@ module Clflags : sig | Restrict of { names : Package.Name.Set.t ; command_line_option : string - (** Which of [-p], [--only-packages], ... was passed *) + (** Which of [-p], [--only-packages], ... was passed *) } (** This must be called exactly once *) diff --git a/src/dune_rules/opam_create.ml b/src/dune_rules/opam_create.ml index 2dcf1f96b05..50b4cd5b124 100644 --- a/src/dune_rules/opam_create.ml +++ b/src/dune_rules/opam_create.ml @@ -187,8 +187,9 @@ let insert_odoc_dep depends = let rec loop acc = function | [] -> List.rev (odoc_dep :: acc) | (dep : Package_dependency.t) :: rest -> - if Package.Name.equal dep.name odoc_name - && Option.forall ~f:already_requires_odoc dep.constraint_ + if + Package.Name.equal dep.name odoc_name + && Option.forall ~f:already_requires_odoc dep.constraint_ then (* Stop now as odoc will be required anyway *) List.rev_append (dep :: acc) rest else loop (dep :: acc) rest diff --git a/src/dune_rules/packages.ml b/src/dune_rules/packages.ml index 4097dca6b71..8dbb7511ec5 100644 --- a/src/dune_rules/packages.ml +++ b/src/dune_rules/packages.ml @@ -9,29 +9,29 @@ let mlds_by_package_def = ~implicit_output:Rules.implicit_output ~input:(module Super_context.As_memo_key) (fun sctx -> - let ctx = Super_context.context sctx in - Context.name ctx - |> Dune_load.dune_files - >>= Memo.parallel_map ~f:(fun dune_file -> - Dune_file.stanzas dune_file - >>= Memo.parallel_map ~f:(fun stanza -> - match Stanza.repr stanza with - | Documentation.T stanza -> - let+ mlds = - (let dir = - Path.Build.append_source - (Context.build_dir ctx) - (Dune_file.dir dune_file) - in - Dir_contents.get sctx ~dir) - >>= Dir_contents.mlds ~stanza - in - let name = Package.name stanza.package in - Some (name, mlds) - | _ -> Memo.return None) - >>| List.filter_opt) - >>| List.concat - >>| Package.Name.Map.of_list_reduce ~f:List.rev_append) + let ctx = Super_context.context sctx in + Context.name ctx + |> Dune_load.dune_files + >>= Memo.parallel_map ~f:(fun dune_file -> + Dune_file.stanzas dune_file + >>= Memo.parallel_map ~f:(fun stanza -> + match Stanza.repr stanza with + | Documentation.T stanza -> + let+ mlds = + (let dir = + Path.Build.append_source + (Context.build_dir ctx) + (Dune_file.dir dune_file) + in + Dir_contents.get sctx ~dir) + >>= Dir_contents.mlds ~stanza + in + let name = Package.name stanza.package in + Some (name, mlds) + | _ -> Memo.return None) + >>| List.filter_opt) + >>| List.concat + >>| Package.Name.Map.of_list_reduce ~f:List.rev_append) ;; let mlds_by_package = Memo.With_implicit_output.exec mlds_by_package_def diff --git a/src/dune_rules/pkg_rules.ml b/src/dune_rules/pkg_rules.ml index 36c69c80a58..74b7abf87a0 100644 --- a/src/dune_rules/pkg_rules.ml +++ b/src/dune_rules/pkg_rules.ml @@ -705,16 +705,16 @@ module Run_with_path = struct Array.Immutable.to_list_map args ~f:(fun x -> Sexp.List (Array.Immutable.to_list_map x ~f:(function - | String s -> Sexp.Atom s - | Path p -> path p))) + | String s -> Sexp.Atom s + | Path p -> path p))) in List [ List ([ prog ] @ args); path ocamlfind_destdir ] ;; let action - { prog; args; ocamlfind_destdir; pkg; depexts } - ~(ectx : Action.context) - ~(eenv : Action.env) + { prog; args; ocamlfind_destdir; pkg; depexts } + ~(ectx : Action.context) + ~(eenv : Action.env) = let open Fiber.O in let display = !Clflags.display in @@ -793,8 +793,8 @@ module Action_expander = struct ;; let section_dir_of_root - (roots : _ Install.Roots.t) - (section : Pform.Var.Pkg.Section.t) + (roots : _ Install.Roots.t) + (section : Pform.Var.Pkg.Section.t) = match section with | Lib -> roots.lib_root @@ -891,17 +891,17 @@ module Action_expander = struct ;; let expand_pform - { name = _ - ; env = _ - ; paths - ; artifacts = _ - ; context - ; depends - ; version = _ - ; depexts = _ - } - ~source - (pform : Pform.t) + { name = _ + ; env = _ + ; paths + ; artifacts = _ + ; context + ; depends + ; version = _ + ; depexts = _ + } + ~source + (pform : Pform.t) : (Value.t list, [ `Undefined_pkg_var of Package_variable_name.t ]) result Memo.t = let loc = Dune_sexp.Template.Pform.loc source in @@ -1432,15 +1432,15 @@ module Install_action = struct let version = 1 let bimap - ({ install_file - ; config_file - ; target_dir - ; prefix_outside_build_dir = _ - ; install_action = _ - ; package = _ - } as t) - f - g + ({ install_file + ; config_file + ; target_dir + ; prefix_outside_build_dir = _ + ; install_action = _ + ; package = _ + } as t) + f + g = { t with install_file = f install_file @@ -1452,15 +1452,15 @@ module Install_action = struct let is_useful_to ~memoize = memoize let encode - { install_file - ; config_file - ; target_dir - ; prefix_outside_build_dir - ; install_action - ; package - } - path - target + { install_file + ; config_file + ; target_dir + ; prefix_outside_build_dir + ; install_action + ; package + } + path + target : Sexp.t = List @@ -1666,15 +1666,15 @@ module Install_action = struct ;; let action - { package - ; install_file - ; config_file - ; target_dir - ; prefix_outside_build_dir - ; install_action - } - ~ectx:_ - ~eenv:_ + { package + ; install_file + ; config_file + ; target_dir + ; prefix_outside_build_dir + ; install_action + } + ~ectx:_ + ~eenv:_ = let open Fiber.O in let* () = Fiber.return () in @@ -2148,10 +2148,10 @@ let which context = "Loading all binaries in the lock directory for %S" (Context_name.to_string context)) (fun () -> - let+ { binaries; dep_info = _ } = - all_packages context >>= Action_expander.Artifacts_and_deps.of_closure - in - binaries) + let+ { binaries; dep_info = _ } = + all_packages context >>= Action_expander.Artifacts_and_deps.of_closure + in + binaries) in Staged.stage (fun program -> let+ artifacts = Memo.Lazy.force artifacts_and_deps in @@ -2203,10 +2203,10 @@ let find_package ctx pkg = | true -> resolve_pkg_project ctx (Loc.none, pkg) >>| (function - | `System_provided -> Action_builder.return () - | `Inside_lock_dir pkg -> - let open Action_builder.O in - let+ _cookie = (Pkg_installed.of_paths pkg.paths).cookie in - ()) + | `System_provided -> Action_builder.return () + | `Inside_lock_dir pkg -> + let open Action_builder.O in + let+ _cookie = (Pkg_installed.of_paths pkg.paths).cookie in + ()) >>| Option.some ;; diff --git a/src/dune_rules/pp_spec_rules.ml b/src/dune_rules/pp_spec_rules.ml index b4aa4a141ec..fa1eb75ba47 100644 --- a/src/dune_rules/pp_spec_rules.ml +++ b/src/dune_rules/pp_spec_rules.ml @@ -206,15 +206,15 @@ let lint_module sctx ~sandbox ~dir ~expander ~lint ~lib_name ~scope = ;; let pp_one_module - sctx - ~lib_name - ~scope - ~preprocessor_deps - ~(lint_module : source:_ -> ast:_ -> unit Memo.t) - ~sandbox - ~dir - ~expander - (pp : _ Preprocess.Without_future_syntax.t) + sctx + ~lib_name + ~scope + ~preprocessor_deps + ~(lint_module : source:_ -> ast:_ -> unit Memo.t) + ~sandbox + ~dir + ~expander + (pp : _ Preprocess.Without_future_syntax.t) = let open Action_builder.O in match pp with @@ -365,15 +365,15 @@ let pp_one_module ;; let make - sctx - ~dir - ~expander - ~lint - ~preprocess - ~preprocessor_deps - ~instrumentation_deps - ~lib_name - ~scope + sctx + ~dir + ~expander + ~lint + ~preprocess + ~preprocessor_deps + ~instrumentation_deps + ~lib_name + ~scope = let preprocessor_deps = preprocessor_deps @ instrumentation_deps in let+ ocaml = Context.ocaml (Super_context.context sctx) in diff --git a/src/dune_rules/ppx_driver.ml b/src/dune_rules/ppx_driver.ml index cb42f95a9d1..fecd4a5ae68 100644 --- a/src/dune_rules/ppx_driver.ml +++ b/src/dune_rules/ppx_driver.ml @@ -280,7 +280,8 @@ let build_ppx_driver sctx ~scope ~target ~pps ~pp_names = let& pps = Lib.closure ~linking:true pps in Driver.select pps ~loc:(Dot_ppx (target, pp_names)) >>| Resolve.map ~f:(fun driver -> driver, pps) - >>| (* Extend the dependency stack as we don't have locations at this + >>| + (* Extend the dependency stack as we don't have locations at this point *) Resolve.push_stack_frame ~human_readable_description:(fun () -> Dyn.pp (List [ String "pps"; Dyn.(list Lib_name.to_dyn) pp_names ])) @@ -403,13 +404,13 @@ let get_cookies ~loc ~expander ~lib_name libs = ;; let ppx_driver_and_flags_internal - context - ~dune_version - ~loc - ~expander - ~lib_name - ~flags - libs + context + ~dune_version + ~loc + ~expander + ~lib_name + ~flags + libs = let open Action_builder.O in let+ flags = diff --git a/src/dune_rules/scope.ml b/src/dune_rules/scope.ml index e31dd6c3dd9..81cac444a54 100644 --- a/src/dune_rules/scope.ml +++ b/src/dune_rules/scope.ml @@ -297,14 +297,14 @@ module DB = struct module Path_source_map_traversals = Memo.Make_parallel_map (Path.Source.Map) let scopes_by_dir - ~build_dir - ~lib_config - ~projects_by_root - ~public_libs - ~instrument_with - context - stanzas - coq_stanzas + ~build_dir + ~lib_config + ~projects_by_root + ~public_libs + ~instrument_with + context + stanzas + coq_stanzas = let stanzas_by_project_dir = List.map stanzas ~f:(fun (dir, stanza) -> diff --git a/src/dune_rules/simple_rules.ml b/src/dune_rules/simple_rules.ml index d5ffa61a30f..7159b3f1693 100644 --- a/src/dune_rules/simple_rules.ml +++ b/src/dune_rules/simple_rules.ml @@ -60,11 +60,11 @@ let interpret_and_add_locks ~expander locks action = ;; let add_user_rule - sctx - ~dir - ~(rule : Rule_conf.t) - ~(action : Action.Full.t Action_builder.With_targets.t) - ~expander + sctx + ~dir + ~(rule : Rule_conf.t) + ~(action : Action.Full.t Action_builder.With_targets.t) + ~expander = let action = let build = interpret_and_add_locks ~expander rule.locks action.build in @@ -157,8 +157,9 @@ let copy_files sctx ~dir ~expander ~src_dir (def : Copy_files.t) = Path.external_ (Path.External.of_string src_glob)) in let since = 1, 3 in - if def.syntax_version < since - && not (Path.is_descendant glob_in_src ~of_:(Path.source src_dir)) + if + def.syntax_version < since + && not (Path.is_descendant glob_in_src ~of_:(Path.source src_dir)) then Dune_lang.Syntax.Error.since loc diff --git a/src/dune_rules/sites/generate_sites_module_stanza.mli b/src/dune_rules/sites/generate_sites_module_stanza.mli index 933e05e2203..98bee7187b4 100644 --- a/src/dune_rules/sites/generate_sites_module_stanza.mli +++ b/src/dune_rules/sites/generate_sites_module_stanza.mli @@ -7,11 +7,11 @@ type t = ; module_ : Module_name.t (** name of the module to generate *) ; sourceroot : bool (** should the sourceroot of the project be provided *) ; relocatable : bool - (** should the fact that the installation use the relocatable mode *) + (** should the fact that the installation use the relocatable mode *) ; sites : (Loc.t * Package.Name.t) list - (** list of the sites whose location should be given *) + (** list of the sites whose location should be given *) ; plugins : (Loc.t * (Package.Name.t * (Loc.t * Site.t))) list - (** list of the sites for which a plugin system must be provided *) + (** list of the sites for which a plugin system must be provided *) } val decode : t Dune_sexp.Decoder.t diff --git a/src/dune_rules/slang_expand.ml b/src/dune_rules/slang_expand.ml index e2565266d08..eb785586be3 100644 --- a/src/dune_rules/slang_expand.ml +++ b/src/dune_rules/slang_expand.ml @@ -22,7 +22,7 @@ let rec eval_rec (t : Slang.t) ~dir ~(f : expander) | Literal sw -> f sw >>| Result.map_error ~f:(function `Undefined_pkg_var variable_name -> - Undefined_pkg_var { literal = sw; variable_name }) + Undefined_pkg_var { literal = sw; variable_name }) | Form (_loc, form) -> (match form with | Concat xs -> diff --git a/src/dune_rules/source_tree.ml b/src/dune_rules/source_tree.ml index 88db4316947..89434bf94eb 100644 --- a/src/dune_rules/source_tree.ml +++ b/src/dune_rules/source_tree.ml @@ -221,13 +221,13 @@ end = struct end let contents - readdir - ~vcs - ~path - ~parent_dune_file - ~dirs_visited - ~project - ~(dir_status : Source_dir_status.t) + readdir + ~vcs + ~path + ~parent_dune_file + ~dirs_visited + ~project + ~(dir_status : Source_dir_status.t) = let files = Readdir.files readdir in let+ dune_file = @@ -274,12 +274,9 @@ end = struct ~files:(Readdir.files readdir) ~infer_from_opam_files:true >>| (function - | Some p -> p - | None -> - Dune_project.anonymous - ~dir:path - Package_info.empty - Package.Name.Map.empty) + | Some p -> p + | None -> + Dune_project.anonymous ~dir:path Package_info.empty Package.Name.Map.empty) >>| Only_packages.filter_packages_in_project ~vendored:(dir_status = Vendored) in let vcs = Dir0.Vcs.get_vcs ~default:Dir0.Vcs.Ancestor_vcs ~readdir ~path in diff --git a/src/dune_rules/stanzas/buildable.ml b/src/dune_rules/stanzas/buildable.ml index 5b6a3ca86ff..3f91907b9ef 100644 --- a/src/dune_rules/stanzas/buildable.ml +++ b/src/dune_rules/stanzas/buildable.ml @@ -132,9 +132,10 @@ let decode (for_ : for_) = in let foreign_archives = let foreign_archives = Option.value ~default:[] foreign_archives in - if version < (2, 0) - && List.is_non_empty foreign_stubs - && Option.is_some self_build_stubs_archive + if + version < (2, 0) + && List.is_non_empty foreign_stubs + && Option.is_some self_build_stubs_archive then User_error.raise ~loc:self_build_stubs_archive_loc diff --git a/src/dune_rules/stanzas/deprecated_library_name.ml b/src/dune_rules/stanzas/deprecated_library_name.ml index 99ff37ccb73..6abbf585aba 100644 --- a/src/dune_rules/stanzas/deprecated_library_name.ml +++ b/src/dune_rules/stanzas/deprecated_library_name.ml @@ -12,8 +12,9 @@ module Old_name = struct let+ public = Public_lib.decode ~allow_deprecated_names:true in let deprecation = let deprecated_package = Lib_name.package_name (Public_lib.name public) in - if let name = Package.name (Public_lib.package public) in - Package.Name.equal deprecated_package name + if + let name = Package.name (Public_lib.package public) in + Package.Name.equal deprecated_package name then Not_deprecated else Deprecated { deprecated_package } in diff --git a/src/dune_rules/stanzas/library.ml b/src/dune_rules/stanzas/library.ml index c0a4f42c6d2..44996c3168d 100644 --- a/src/dune_rules/stanzas/library.ml +++ b/src/dune_rules/stanzas/library.ml @@ -409,11 +409,12 @@ let to_lib_id ~src_dir t = ;; let to_lib_info - conf - ~expander - ~dir - ~lib_config: - ({ Lib_config.has_native; ext_lib; ext_dll; natdynlink_supported; _ } as lib_config) + conf + ~expander + ~dir + ~lib_config: + ({ Lib_config.has_native; ext_lib; ext_dll; natdynlink_supported; _ } as + lib_config) = let open Memo.O in let obj_dir = obj_dir ~dir conf in @@ -457,10 +458,10 @@ let to_lib_info let archive = archive ext_lib in if virtual_library || not modes.ocaml.native then Lib_info.Files [] - else if Option.is_some conf.implements - || (Lib_config.linker_can_create_empty_archives lib_config - && Ocaml.Version.ocamlopt_always_calls_library_linker - lib_config.ocaml_version) + else if + Option.is_some conf.implements + || (Lib_config.linker_can_create_empty_archives lib_config + && Ocaml.Version.ocamlopt_always_calls_library_linker lib_config.ocaml_version) then Lib_info.Files [ archive ] else Lib_info.Needs_module_info archive in diff --git a/src/dune_rules/stanzas/library.mli b/src/dune_rules/stanzas/library.mli index 1923ef0fa17..6119f2aa107 100644 --- a/src/dune_rules/stanzas/library.mli +++ b/src/dune_rules/stanzas/library.mli @@ -13,7 +13,7 @@ type t = ; ppx_runtime_libraries : (Loc.t * Lib_name.t) list ; modes : Mode_conf.Lib.Set.t ; kind : Lib_kind.t - (* TODO: It may be worth remaming [c_library_flags] to + (* TODO: It may be worth remaming [c_library_flags] to [link_time_flags_for_c_compiler] and [library_flags] to [link_time_flags_for_ocaml_compiler], both here and in the Dune language, to make it easier to understand the purpose of various diff --git a/src/dune_rules/super_context.ml b/src/dune_rules/super_context.ml index d668344e6fc..c9efb63b726 100644 --- a/src/dune_rules/super_context.ml +++ b/src/dune_rules/super_context.ml @@ -60,13 +60,13 @@ let expander t ~dir = let get_env_stanza ~dir = Dune_load.stanzas_in_dir dir >>= (function - | None -> Memo.return None - | Some dune_file -> - Dune_file.find_stanzas dune_file Dune_env.key - >>| (function - | [] -> None - | [ x ] -> Some x - | _ :: _ -> assert false)) + | None -> Memo.return None + | Some dune_file -> + Dune_file.find_stanzas dune_file Dune_env.key + >>| (function + | [] -> None + | [ x ] -> Some x + | _ :: _ -> assert false)) >>| Option.value ~default:Dune_env.empty ;; @@ -189,11 +189,11 @@ let resolve_program t ~dir ?where ?hint ~loc bin = ;; let make_default_env_node - (context : Build_context.t) - profile - (env_nodes : Context.Env_nodes.t) - ~root_env - ~artifacts + (context : Build_context.t) + profile + (env_nodes : Context.Env_nodes.t) + ~root_env + ~artifacts = let make ~inherit_from ~config_stanza = let config_stanza = Option.value config_stanza ~default:Dune_env.empty in diff --git a/src/dune_rules/virtual_rules.ml b/src/dune_rules/virtual_rules.ml index 21688074020..b344114536e 100644 --- a/src/dune_rules/virtual_rules.ml +++ b/src/dune_rules/virtual_rules.ml @@ -43,8 +43,8 @@ let setup_copy_rules_for_impl ~sctx ~dir vimpl = (Module.visibility src = Public && Obj_dir.need_dedicated_public_dir impl_obj_dir) (fun () -> - Memo.when_ (byte || native) (copy_interface_to_impl ~src (Ocaml Cmi)) - >>> Memo.when_ melange (copy_interface_to_impl ~src (Melange Cmi))) + Memo.when_ (byte || native) (copy_interface_to_impl ~src (Ocaml Cmi)) + >>> Memo.when_ melange (copy_interface_to_impl ~src (Melange Cmi))) >>> Memo.when_ (Module.has src ~ml_kind:Impl) (fun () -> Memo.when_ byte (fun () -> copy_obj_file src (Ocaml Cmo)) >>> Memo.when_ melange (fun () -> diff --git a/src/dune_rules/workspace.ml b/src/dune_rules/workspace.ml index 3bde8600353..2dc18e879fb 100644 --- a/src/dune_rules/workspace.ml +++ b/src/dune_rules/workspace.ml @@ -16,14 +16,14 @@ module Lock_dir = struct } let to_dyn - { path - ; version_preference - ; solver_env - ; unset_solver_vars - ; repositories - ; constraints - ; pins - } + { path + ; version_preference + ; solver_env + ; unset_solver_vars + ; repositories + ; constraints + ; pins + } = Dyn.record [ "path", Path.Source.to_dyn path @@ -41,14 +41,14 @@ module Lock_dir = struct ;; let hash - { path - ; version_preference - ; solver_env - ; unset_solver_vars - ; repositories - ; constraints - ; pins - } + { path + ; version_preference + ; solver_env + ; unset_solver_vars + ; repositories + ; constraints + ; pins + } = Poly.hash ( path @@ -61,15 +61,15 @@ module Lock_dir = struct ;; let equal - { path - ; version_preference - ; solver_env - ; unset_solver_vars - ; repositories - ; constraints - ; pins - } - t + { path + ; version_preference + ; solver_env + ; unset_solver_vars + ; repositories + ; constraints + ; pins + } + t = Path.Source.equal path t.path && Option.equal @@ -313,20 +313,20 @@ module Context = struct ;; let equal - { loc = _ - ; profile - ; targets - ; env - ; toolchain - ; name - ; host_context - ; paths - ; fdo_target_exe - ; dynamically_linked_foreign_archives - ; instrument_with - ; merlin - } - t + { loc = _ + ; profile + ; targets + ; env + ; toolchain + ; name + ; host_context + ; paths + ; fdo_target_exe + ; dynamically_linked_foreign_archives + ; instrument_with + ; merlin + } + t = Profile.equal profile t.profile && List.equal Target.equal targets t.targets @@ -701,13 +701,13 @@ module Clflags = struct } let to_dyn - { x - ; profile - ; instrument_with - ; workspace_file - ; config_from_command_line - ; config_from_config_file - } + { x + ; profile + ; instrument_with + ; workspace_file + ; config_from_command_line + ; config_from_config_file + } = let open Dyn in record @@ -773,9 +773,9 @@ let top_sort contexts = ;; let create_final_config - ~config_from_config_file - ~config_from_command_line - ~config_from_workspace_file + ~config_from_config_file + ~config_from_command_line + ~config_from_workspace_file = let ( ++ ) = Dune_config.superpose in Dune_config.default @@ -905,9 +905,10 @@ let step1 clflags = match merlin_context with | Some _ -> merlin_context | None -> - if List.exists contexts ~f:(function - | Context.Default _ -> true - | _ -> false) + if + List.exists contexts ~f:(function + | Context.Default _ -> true + | _ -> false) then Some Context_name.default else None in diff --git a/src/dune_rules/workspace.mli b/src/dune_rules/workspace.mli index 45a3e45bf8e..a370ed15059 100644 --- a/src/dune_rules/workspace.mli +++ b/src/dune_rules/workspace.mli @@ -59,7 +59,7 @@ module Context : sig ; host_context : Context_name.t option ; paths : (string * Ordered_set_lang.t) list ; fdo_target_exe : Path.t option - (** By default Dune builds and installs dynamically linked foreign + (** By default Dune builds and installs dynamically linked foreign archives (usually named [dll*.so]). It is possible to disable this by setting [disable_dynamically_linked_foreign_archives] to [true] in the workspace file, in which case bytecode executables @@ -74,7 +74,7 @@ module Context : sig module Opam : sig type t = { base : Common.t - (** Either a switch name or a path to a local switch. This argument + (** Either a switch name or a path to a local switch. This argument is left opaque as we leave to opam to interpret it. *) ; switch : Opam_switch.t } diff --git a/src/dune_sexp/cst.ml b/src/dune_sexp/cst.ml index b903edfd26a..a8b5a6d6b32 100644 --- a/src/dune_sexp/cst.ml +++ b/src/dune_sexp/cst.ml @@ -18,11 +18,11 @@ let rec to_dyn = ;; let loc - ( Atom (loc, _) - | Quoted_string (loc, _) - | List (loc, _) - | Template { loc; _ } - | Comment (loc, _) ) + ( Atom (loc, _) + | Quoted_string (loc, _) + | List (loc, _) + | Template { loc; _ } + | Comment (loc, _) ) = loc ;; diff --git a/src/dune_sexp/decoder.ml b/src/dune_sexp/decoder.ml index 5467ef48449..616af06f444 100644 --- a/src/dune_sexp/decoder.ml +++ b/src/dune_sexp/decoder.ml @@ -725,11 +725,11 @@ let fields_mutual_exclusion_violation loc names = ;; let fields_mutually_exclusive - ?on_dup - ?default - fields - ((Fields (loc, _, _) : _ context) as ctx) - state + ?on_dup + ?default + fields + ((Fields (loc, _, _) : _ context) as ctx) + state = let res, state = traverse diff --git a/src/dune_sexp/syntax.ml b/src/dune_sexp/syntax.ml index c2108c0b214..358cad8f68d 100644 --- a/src/dune_sexp/syntax.ml +++ b/src/dune_sexp/syntax.ml @@ -46,8 +46,8 @@ module Version = struct ;; let can_read - ~parser_version:(parser_major, parser_minor) - ~data_version:(data_major, data_minor) + ~parser_version:(parser_major, parser_minor) + ~data_version:(data_major, data_minor) = let open Int.Infix in parser_major = data_major && parser_minor >= data_minor @@ -115,7 +115,7 @@ end = struct {[ (Version.t Int.Map.t) Int.Map.t ]} which is a list of major versions paired with lists of minor versions paires with a dune_lang version. *) let make - (versions : (Version.t * [ `Since of Version.t | `Deleted_in of Version.t ]) list) + (versions : (Version.t * [ `Since of Version.t | `Deleted_in of Version.t ]) list) : t = let version_map, deleted_in = diff --git a/src/dune_sexp/template.ml b/src/dune_sexp/template.ml index 9b664152eee..69f06f925e1 100644 --- a/src/dune_sexp/template.ml +++ b/src/dune_sexp/template.ml @@ -209,10 +209,11 @@ let to_string = Pp.to_string let pp t = Stdune.Pp.verbatim (Pp.to_string t) let pp_split_strings ppf (t : t) = - if t.quoted - || List.exists t.parts ~f:(function - | Text s -> String.contains s '\n' - | Pform _ -> false) + if + t.quoted + || List.exists t.parts ~f:(function + | Text s -> String.contains s '\n' + | Pform _ -> false) then ( List.iter t.parts ~f:(function | Pform s -> Format.pp_print_string ppf (Pform.to_string s) diff --git a/src/dune_targets/dune_targets.ml b/src/dune_targets/dune_targets.ml index 4fd1cf81fbc..99d591f1a20 100644 --- a/src/dune_targets/dune_targets.ml +++ b/src/dune_targets/dune_targets.ml @@ -330,9 +330,9 @@ module Produced = struct ;; let equal - { root = root1; files = files1; dirs = dirs1 } - { root = root2; files = files2; dirs = dirs2 } - ~equal + { root = root1; files = files1; dirs = dirs1 } + { root = root2; files = files2; dirs = dirs2 } + ~equal = Path.Build.equal root1 root2 && Filename.Map.equal files1 files2 ~equal @@ -368,12 +368,12 @@ module Produced = struct let+ files, dirs = Fiber.fork_and_join (fun () -> - Filename_traversal.parallel_map files ~f:(fun file -> - f (Path.Local.of_string file))) + Filename_traversal.parallel_map files ~f:(fun file -> + f (Path.Local.of_string file))) (fun () -> - Path_traversal.parallel_map dirs ~f:(fun dir files -> - Filename_traversal.parallel_map files ~f:(fun file payload -> - f (Path.Local.relative dir file) payload))) + Path_traversal.parallel_map dirs ~f:(fun dir files -> + Filename_traversal.parallel_map files ~f:(fun file payload -> + f (Path.Local.relative dir file) payload))) in { root; files; dirs } ;; @@ -389,9 +389,9 @@ module Produced = struct exception Short_circuit let map_with_errors - { root; files; dirs } - ~all_errors - ~(f : Path.Build.t -> 'a -> ('b, 'e) result) + { root; files; dirs } + ~all_errors + ~(f : Path.Build.t -> 'a -> ('b, 'e) result) = let errors = ref [] in let f path a = diff --git a/src/dune_tui/dune_tui.ml b/src/dune_tui/dune_tui.ml index 461424cefda..1f4b7f85d87 100644 --- a/src/dune_tui/dune_tui.ml +++ b/src/dune_tui/dune_tui.ml @@ -295,10 +295,11 @@ module Console_backend = struct Ordering.is_eq (Pp.compare ~compare:User_message.Style.compare x y))) status_line state.status_line; - if let l = Lwd.peek messages in - not - (List.length l = Queue.length state.messages - && List.equal User_message.equal l (Queue.to_list state.messages)) + if + let l = Lwd.peek messages in + not + (List.length l = Queue.length state.messages + && List.equal User_message.equal l (Queue.to_list state.messages)) then Lwd.set messages (Queue.to_list state.messages) ;; diff --git a/src/dune_tui/widgets/button.ml b/src/dune_tui/widgets/button.ml index d0ad35bcb63..e56eec51f64 100644 --- a/src/dune_tui/widgets/button.ml +++ b/src/dune_tui/widgets/button.ml @@ -3,7 +3,7 @@ open Import let of_ ui f = Ui.mouse_area (fun ~x:_ ~y:_ _ -> - f (); - `Handled) + f (); + `Handled) ui ;; diff --git a/src/dune_util/gc.ml b/src/dune_util/gc.ml index 0e7009638d5..52afdce9a1b 100644 --- a/src/dune_util/gc.ml +++ b/src/dune_util/gc.ml @@ -1,25 +1,25 @@ open Stdune let to_sexp - ({ Stdlib.Gc.minor_words - ; promoted_words - ; major_words - ; minor_collections - ; major_collections - ; heap_words - ; heap_chunks - ; live_words - ; live_blocks - ; free_words - ; free_blocks - ; largest_free - ; fragments - ; compactions - ; top_heap_words - ; stack_size - ; _ - } : - Stdlib.Gc.stat) + ({ Stdlib.Gc.minor_words + ; promoted_words + ; major_words + ; minor_collections + ; major_collections + ; heap_words + ; heap_chunks + ; live_words + ; live_blocks + ; free_words + ; free_blocks + ; largest_free + ; fragments + ; compactions + ; top_heap_words + ; stack_size + ; _ + } : + Stdlib.Gc.stat) : Sexp.t = let open Sexp in diff --git a/src/fsevents/fsevents.ml b/src/fsevents/fsevents.ml index 861af543a57..9175e27acaf 100644 --- a/src/fsevents/fsevents.ml +++ b/src/fsevents/fsevents.ml @@ -119,30 +119,30 @@ module Event = struct } let to_dyn - { must_scan_subdirs - ; user_dropped - ; kernel_dropped - ; event_ids_wrapped - ; history_done - ; root_changed - ; mount - ; unmount - ; own_event - ; item_created - ; item_removed - ; item_inode_meta_mod - ; item_renamed - ; item_modified - ; item_finder_info_mod - ; item_change_owner - ; item_xattr_mod - ; item_is_file - ; item_is_dir - ; item_is_symlink - ; item_is_hardlink - ; item_is_last_hardlink - ; item_cloned - } + { must_scan_subdirs + ; user_dropped + ; kernel_dropped + ; event_ids_wrapped + ; history_done + ; root_changed + ; mount + ; unmount + ; own_event + ; item_created + ; item_removed + ; item_inode_meta_mod + ; item_renamed + ; item_modified + ; item_finder_info_mod + ; item_change_owner + ; item_xattr_mod + ; item_is_file + ; item_is_dir + ; item_is_symlink + ; item_is_hardlink + ; item_is_last_hardlink + ; item_cloned + } = let open Dyn in record diff --git a/src/install/paths.ml b/src/install/paths.ml index 749b7df411e..f3a08eee9e9 100644 --- a/src/install/paths.ml +++ b/src/install/paths.ml @@ -17,21 +17,21 @@ type 'path t = } let map - { lib - ; lib_root - ; libexec - ; libexec_root - ; bin - ; sbin - ; toplevel - ; share - ; share_root - ; etc - ; doc - ; stublibs - ; man - } - ~f + { lib + ; lib_root + ; libexec + ; libexec_root + ; bin + ; sbin + ; toplevel + ; share + ; share_root + ; etc + ; doc + ; stublibs + ; man + } + ~f = { lib = f lib ; lib_root = f lib_root diff --git a/src/memo/memo.ml b/src/memo/memo.ml index fd8e1c70435..580a2af7077 100644 --- a/src/memo/memo.ml +++ b/src/memo/memo.ml @@ -179,7 +179,7 @@ module M = struct and Dep_node : sig type ('i, 'o) t = { id : Id.t - (* If [id] is placed first in this data structure, then polymorphic + (* If [id] is placed first in this data structure, then polymorphic comparison for dep nodes works fine regardless of the other fields. At the moment polymorphic comparison is used for [Exn_set], but we hope to change that. *) @@ -433,8 +433,8 @@ module Collect_errors_monoid = struct let empty = { exns = Exn_set.empty; reproducible = true } let combine - { exns = exns1; reproducible = reproducible1 } - { exns = exns2; reproducible = reproducible2 } + { exns = exns1; reproducible = reproducible1 } + { exns = exns2; reproducible = reproducible2 } = { exns = Exn_set.union exns1 exns2; reproducible = reproducible1 && reproducible2 } ;; @@ -850,19 +850,19 @@ module Cached_value = struct if !Debug.check_invariants then List.iter deps_rev ~f:(function Dep_node.T dep_node -> - (match get_cached_value_in_current_run dep_node with - | None -> - let reason = - match dep_node.state with - | Out_of_date _ -> "(out of date)" - | Cached_value _ -> "(old run)" - | Restoring _ -> "(restoring)" - | Computing _ -> "(computing)" - in - Code_error.raise - ("Attempted to create a cached value based on some stale inputs " ^ reason) - [] - | Some _up_to_date_cached_value -> ())); + (match get_cached_value_in_current_run dep_node with + | None -> + let reason = + match dep_node.state with + | Out_of_date _ -> "(out of date)" + | Cached_value _ -> "(old run)" + | Restoring _ -> "(restoring)" + | Computing _ -> "(computing)" + in + Code_error.raise + ("Attempted to create a cached value based on some stale inputs " ^ reason) + [] + | Some _up_to_date_cached_value -> ())); Deps.create ~deps_rev ;; @@ -993,13 +993,13 @@ let invalidate_dep_node (dep_node : _ Dep_node.t) = let invalidate_store = Store.iter ~f:invalidate_dep_node let create_with_cache - (type i o) - name - ~cache - ~input - ~cutoff - ~human_readable_description - (f : i -> o Fiber.t) + (type i o) + name + ~cache + ~input + ~cutoff + ~human_readable_description + (f : i -> o Fiber.t) : (i, o) Table.t = let spec = Spec.create ~name:(Some name) ~input ~cutoff ~human_readable_description f in @@ -1010,25 +1010,25 @@ let create_with_cache ;; let create_with_store - (type i) - name - ~store:(module S : Store_intf.S with type key = i) - ~input - ?cutoff - ?human_readable_description - f + (type i) + name + ~store:(module S : Store_intf.S with type key = i) + ~input + ?cutoff + ?human_readable_description + f = let cache = Store.make (module S) in create_with_cache name ~cache ~input ~cutoff ~human_readable_description f ;; let create - (type i) - name - ~input:(module Input : Input with type t = i) - ?cutoff - ?human_readable_description - f + (type i) + name + ~input:(module Input : Input with type t = i) + ?cutoff + ?human_readable_description + f = (* This mutable table is safe: the implementation tracks all dependencies. *) let cache = Store.of_table (Stdune.Table.create (module Input) 2) in @@ -1145,8 +1145,8 @@ end = struct | Cancelled { dependency_cycle } -> Cancelled { dependency_cycle }) and compute - : 'i 'o. - dep_node:('i, 'o) Dep_node.t + : 'i 'o. + dep_node:('i, 'o) Dep_node.t -> old_value:'o Cached_value.t Option.Unboxed.t -> stack_frame:Stack_frame_with_state.t -> 'o Cached_value.t Fiber.t @@ -1172,8 +1172,8 @@ end = struct | false -> Cached_value.confirm_old_value ~deps_rev old_cv) and start_restoring - : 'i 'o. - dep_node:('i, 'o) Dep_node.t + : 'i 'o. + dep_node:('i, 'o) Dep_node.t -> cached_value:'o Cached_value.t -> 'o Cache_lookup.t Fiber.t = @@ -1191,8 +1191,8 @@ end = struct restore_result) and start_computing - : 'i 'o. - dep_node:('i, 'o) Dep_node.t + : 'i 'o. + dep_node:('i, 'o) Dep_node.t -> old_value:'o Cached_value.t Option.Unboxed.t -> 'o Cached_value.t Fiber.t = @@ -1614,8 +1614,7 @@ struct create name ~input:(module Key) - (function - | Key.T input -> eval input >>| fun v -> Value.T (id input, v)) + (function Key.T input -> eval input >>| fun v -> Value.T (id input, v)) ;; let eval x = exec memo (Key.T x) >>| Value.get ~input_with_matching_id:x @@ -1694,7 +1693,7 @@ module Var = struct type 'a t = { cell : (unit, 'a) Cell.t ; mutable value : 'a - (* We manually cutoff instead of depending on [Cell.t] cutoff mechanism, + (* We manually cutoff instead of depending on [Cell.t] cutoff mechanism, so that we don't pay for invalidation when the value doesn't change. *) ; cutoff : ('a -> 'a -> bool) option } diff --git a/src/ocaml-config/ocaml_config.ml b/src/ocaml-config/ocaml_config.ml index 3a149984c4f..ddea62148f2 100644 --- a/src/ocaml-config/ocaml_config.ml +++ b/src/ocaml-config/ocaml_config.ml @@ -188,59 +188,59 @@ let supports_shared_libraries t = t.supports_shared_libraries let windows_unicode t = t.windows_unicode let to_list - { version = _ - ; version_string - ; standard_library_default - ; standard_library - ; standard_runtime - ; ccomp_type - ; c_compiler - ; ocamlc_cflags - ; ocamlc_cppflags - ; ocamlopt_cflags - ; ocamlopt_cppflags - ; bytecomp_c_compiler - ; bytecomp_c_libraries - ; native_c_compiler - ; native_c_libraries - ; native_pack_linker - ; cc_profile - ; architecture - ; model - ; int_size - ; word_size - ; system - ; asm - ; asm_cfi_supported - ; with_frame_pointers - ; ext_exe - ; ext_obj - ; ext_asm - ; ext_lib - ; ext_dll - ; os_type - ; default_executable_name - ; systhread_supported - ; host - ; target - ; profiling - ; flambda - ; spacetime - ; safe_string - ; exec_magic_number - ; cmi_magic_number - ; cmo_magic_number - ; cma_magic_number - ; cmx_magic_number - ; cmxa_magic_number - ; ast_impl_magic_number - ; ast_intf_magic_number - ; cmxs_magic_number - ; cmt_magic_number - ; natdynlink_supported - ; supports_shared_libraries - ; windows_unicode - } + { version = _ + ; version_string + ; standard_library_default + ; standard_library + ; standard_runtime + ; ccomp_type + ; c_compiler + ; ocamlc_cflags + ; ocamlc_cppflags + ; ocamlopt_cflags + ; ocamlopt_cppflags + ; bytecomp_c_compiler + ; bytecomp_c_libraries + ; native_c_compiler + ; native_c_libraries + ; native_pack_linker + ; cc_profile + ; architecture + ; model + ; int_size + ; word_size + ; system + ; asm + ; asm_cfi_supported + ; with_frame_pointers + ; ext_exe + ; ext_obj + ; ext_asm + ; ext_lib + ; ext_dll + ; os_type + ; default_executable_name + ; systhread_supported + ; host + ; target + ; profiling + ; flambda + ; spacetime + ; safe_string + ; exec_magic_number + ; cmi_magic_number + ; cmo_magic_number + ; cma_magic_number + ; cmx_magic_number + ; cmxa_magic_number + ; ast_impl_magic_number + ; ast_intf_magic_number + ; cmxs_magic_number + ; cmt_magic_number + ; natdynlink_supported + ; supports_shared_libraries + ; windows_unicode + } : (string * Value.t) list = [ "version", String version_string @@ -301,60 +301,60 @@ let to_list functions are the same as the ones used in the below function. *) let by_name - { version = _ - ; version_string - ; standard_library_default - ; standard_library - ; standard_runtime - ; ccomp_type - ; c_compiler - ; ocamlc_cflags - ; ocamlc_cppflags - ; ocamlopt_cflags - ; ocamlopt_cppflags - ; bytecomp_c_compiler - ; bytecomp_c_libraries - ; native_c_compiler - ; native_c_libraries - ; native_pack_linker - ; cc_profile - ; architecture - ; model - ; int_size - ; word_size - ; system - ; asm - ; asm_cfi_supported - ; with_frame_pointers - ; ext_exe - ; ext_obj - ; ext_asm - ; ext_lib - ; ext_dll - ; os_type - ; default_executable_name - ; systhread_supported - ; host - ; target - ; profiling - ; flambda - ; spacetime - ; safe_string - ; exec_magic_number - ; cmi_magic_number - ; cmo_magic_number - ; cma_magic_number - ; cmx_magic_number - ; cmxa_magic_number - ; ast_impl_magic_number - ; ast_intf_magic_number - ; cmxs_magic_number - ; cmt_magic_number - ; natdynlink_supported - ; supports_shared_libraries - ; windows_unicode - } - name + { version = _ + ; version_string + ; standard_library_default + ; standard_library + ; standard_runtime + ; ccomp_type + ; c_compiler + ; ocamlc_cflags + ; ocamlc_cppflags + ; ocamlopt_cflags + ; ocamlopt_cppflags + ; bytecomp_c_compiler + ; bytecomp_c_libraries + ; native_c_compiler + ; native_c_libraries + ; native_pack_linker + ; cc_profile + ; architecture + ; model + ; int_size + ; word_size + ; system + ; asm + ; asm_cfi_supported + ; with_frame_pointers + ; ext_exe + ; ext_obj + ; ext_asm + ; ext_lib + ; ext_dll + ; os_type + ; default_executable_name + ; systhread_supported + ; host + ; target + ; profiling + ; flambda + ; spacetime + ; safe_string + ; exec_magic_number + ; cmi_magic_number + ; cmo_magic_number + ; cma_magic_number + ; cmx_magic_number + ; cmxa_magic_number + ; ast_impl_magic_number + ; ast_intf_magic_number + ; cmxs_magic_number + ; cmt_magic_number + ; natdynlink_supported + ; supports_shared_libraries + ; windows_unicode + } + name : Value.t option = match name with diff --git a/src/opam-0install/lib/model.ml b/src/opam-0install/lib/model.ml index 9fe7db9579f..ec1f5ae83ae 100644 --- a/src/opam-0install/lib/model.ml +++ b/src/opam-0install/lib/model.ml @@ -86,10 +86,9 @@ module Make (Context : S.CONTEXT) = struct let virtual_role impls = let impls = impls - |> List.mapi (fun i -> - function - | VirtualImpl (_, x) -> VirtualImpl (i, x) - | x -> x) + |> List.mapi (fun i -> function + | VirtualImpl (_, x) -> VirtualImpl (i, x) + | x -> x) in Virtual (object end, impls) ;; diff --git a/src/promote/diff_action.ml b/src/promote/diff_action.ml index 7964b37e7ed..dadacc0aa28 100644 --- a/src/promote/diff_action.ml +++ b/src/promote/diff_action.ml @@ -38,32 +38,32 @@ let exec ~rule_loc ({ Diff.optional; file1; file2; mode } as diff) = in Fiber.finalize (fun () -> - let annots = - User_message.Annots.singleton - Dune_engine.Diff_promotion.Annot.annot - { Dune_engine.Diff_promotion.Annot.in_source = source_file - ; in_build = - (if optional && in_source_or_target - then Diff_promotion.File.in_staging_area source_file - else file2) - } - in - if mode = Binary - then - User_error.raise - ~annots - ~loc:rule_loc - [ Pp.textf - "Files %s and %s differ." - (Path.to_string_maybe_quoted file1) - (Path.to_string_maybe_quoted (Path.build file2)) - ] - else - Print_diff.print - annots - file1 - (Path.build file2) - ~skip_trailing_cr:(mode = Text && Sys.win32)) + let annots = + User_message.Annots.singleton + Dune_engine.Diff_promotion.Annot.annot + { Dune_engine.Diff_promotion.Annot.in_source = source_file + ; in_build = + (if optional && in_source_or_target + then Diff_promotion.File.in_staging_area source_file + else file2) + } + in + if mode = Binary + then + User_error.raise + ~annots + ~loc:rule_loc + [ Pp.textf + "Files %s and %s differ." + (Path.to_string_maybe_quoted file1) + (Path.to_string_maybe_quoted (Path.build file2)) + ] + else + Print_diff.print + annots + file1 + (Path.build file2) + ~skip_trailing_cr:(mode = Text && Sys.win32)) ~finally:(fun () -> (match optional with | false -> diff --git a/src/promote/print_diff.ml b/src/promote/print_diff.ml index c5e74581420..b99cce21814 100644 --- a/src/promote/print_diff.ml +++ b/src/promote/print_diff.ml @@ -96,11 +96,11 @@ let prepare ~skip_trailing_cr annots path1 path2 = in let loc = Loc.in_file file1 in let run - ?(dir = dir) - ?(metadata = Process.create_metadata ~purpose:Internal_job ~loc ~annots ()) - prog - args - ~fallback + ?(dir = dir) + ?(metadata = Process.create_metadata ~purpose:Internal_job ~loc ~annots ()) + prog + args + ~fallback = With_fallback.run { dir; prog; args; metadata } ~fallback in @@ -202,8 +202,10 @@ let prepare ~skip_trailing_cr annots path1 path2 = User_message.Annots.has_embedded_location ()) ()) - ~fallback:((* Use "diff" if "patdiff" reported no differences *) - normal_diff ())) + ~fallback: + ((* Use "diff" if "patdiff" reported no differences *) + normal_diff + ())) ;; let print ?(skip_trailing_cr = Sys.win32) annots path1 path2 = diff --git a/src/scheme/scheme.ml b/src/scheme/scheme.ml index 5944829b75f..8853a7de424 100644 --- a/src/scheme/scheme.ml +++ b/src/scheme/scheme.ml @@ -124,8 +124,9 @@ let evaluate ~union_rules = and+ y = loop ~env y in Evaluated.union ~union_rules x y | Approximation (paths, rules) -> - if (not (Dir_set.is_subset paths ~of_:env)) - && not (Dir_set.is_subset (Dir_set.negate paths) ~of_:env) + if + (not (Dir_set.is_subset paths ~of_:env)) + && not (Dir_set.is_subset (Dir_set.negate paths) ~of_:env) then Code_error.raise "inner [Approximate] specifies a set such that neither it, nor its negation, \ diff --git a/test/expect-tests/csexp_rpc/csexp_rpc_tests.ml b/test/expect-tests/csexp_rpc/csexp_rpc_tests.ml index ef3b6298611..4f0c66a8cc8 100644 --- a/test/expect-tests/csexp_rpc/csexp_rpc_tests.ml +++ b/test/expect-tests/csexp_rpc/csexp_rpc_tests.ml @@ -60,32 +60,32 @@ let%expect_test "csexp server life cycle" = let client = Csexp_rpc.Server.listening_address server |> List.hd |> client in Fiber.fork_and_join_unit (fun () -> - let log fmt = Logger.log client_log fmt in - let* client = Client.connect_exn client in - let* () = Session.write client [ List [ Atom "from client" ] ] >>| ok_exn in - log "written"; - let* response = Session.read client in - (match response with - | None -> log "no response" - | Some sexp -> log "received %s" (Csexp.to_string sexp)); - let* () = Session.close client in - log "closed"; - Server.stop server) + let log fmt = Logger.log client_log fmt in + let* client = Client.connect_exn client in + let* () = Session.write client [ List [ Atom "from client" ] ] >>| ok_exn in + log "written"; + let* response = Session.read client in + (match response with + | None -> log "no response" + | Some sexp -> log "received %s" (Csexp.to_string sexp)); + let* () = Session.close client in + log "closed"; + Server.stop server) (fun () -> - let log fmt = Logger.log server_log fmt in - let+ () = - Fiber.Stream.In.parallel_iter sessions ~f:(fun session -> - log "received session"; - let* res = Csexp_rpc.Session.read session in - match res with - | None -> - log "session terminated"; - Fiber.return () - | Some csexp -> - log "received %s" (Csexp.to_string csexp); - Session.write session [ List [ Atom "from server" ] ] >>| ok_exn) - in - log "sessions finished") + let log fmt = Logger.log server_log fmt in + let+ () = + Fiber.Stream.In.parallel_iter sessions ~f:(fun session -> + log "received session"; + let* res = Csexp_rpc.Session.read session in + match res with + | None -> + log "session terminated"; + Fiber.return () + | Some csexp -> + log "received %s" (Csexp.to_string csexp); + Session.write session [ List [ Atom "from server" ] ] >>| ok_exn) + in + log "sessions finished") in Dune_engine.Clflags.display := Quiet; let config = diff --git a/test/expect-tests/csexp_rpc/io_buffer_tests.ml b/test/expect-tests/csexp_rpc/io_buffer_tests.ml index d47692debf2..75f890689ea 100644 --- a/test/expect-tests/csexp_rpc/io_buffer_tests.ml +++ b/test/expect-tests/csexp_rpc/io_buffer_tests.ml @@ -13,7 +13,8 @@ let%expect_test "resize" = let buf = Io_buffer.create ~size:2 in Io_buffer.write_csexps buf [ Csexp.Atom "xxx" ]; print_dyn buf; - [%expect {| + [%expect + {| { total_written = 0; contents = "3:xxx"; pos_w = 5; pos_r = 0 } |}]; Io_buffer.write_csexps buf [ Csexp.Atom "xxxyyy" ]; print_dyn buf; @@ -26,15 +27,18 @@ let%expect_test "reading" = let buf = Io_buffer.create ~size:10 in Io_buffer.write_csexps buf [ Csexp.Atom "abcde" ]; print_dyn buf; - [%expect {| + [%expect + {| { total_written = 0; contents = "5:abcde"; pos_w = 7; pos_r = 0 } |}]; Io_buffer.read buf 4; print_dyn buf; - [%expect {| + [%expect + {| { total_written = 4; contents = "cde"; pos_w = 7; pos_r = 4 } |}]; Io_buffer.read buf 2; print_dyn buf; - [%expect {| + [%expect + {| { total_written = 6; contents = "e"; pos_w = 7; pos_r = 6 } |}]; (* buffer is now empty, this should now error *) Io_buffer.read buf 2; @@ -49,18 +53,22 @@ let%expect_test "reading" = let buf = Io_buffer.create ~size:1 in Io_buffer.write_csexps buf [ Atom "abc" ]; print_dyn buf; - [%expect {| + [%expect + {| { total_written = 0; contents = "3:abc"; pos_w = 5; pos_r = 0 } |}]; let flush = Io_buffer.flush_token buf in printfn "token: %b" (Io_buffer.flushed buf flush); - [%expect {| + [%expect + {| token: false |}]; Io_buffer.read buf 4; printfn "token: %b" (Io_buffer.flushed buf flush); - [%expect {| + [%expect + {| token: false |}]; Io_buffer.read buf 1; printfn "token: %b" (Io_buffer.flushed buf flush); - [%expect {| + [%expect + {| token: true |}] ;; diff --git a/test/expect-tests/dag/dag_tests.ml b/test/expect-tests/dag/dag_tests.ml index dd199b8e55b..a8616f0cb74 100644 --- a/test/expect-tests/dag/dag_tests.ml +++ b/test/expect-tests/dag/dag_tests.ml @@ -149,7 +149,8 @@ let cycle_test variant = let%expect_test _ = cycle_test `a; - [%expect {| + [%expect + {| 23 22 21 20 14 13 12 11 |}] @@ -157,7 +158,8 @@ let%expect_test _ = let%expect_test _ = cycle_test `b; - [%expect {| + [%expect + {| 23 22 21 20 14 13 12 11 |}] diff --git a/test/expect-tests/dune_action_plugin/dune_action_test.ml b/test/expect-tests/dune_action_plugin/dune_action_test.ml index 72b1abacdba..b0b2d294b2d 100644 --- a/test/expect-tests/dune_action_plugin/dune_action_test.ml +++ b/test/expect-tests/dune_action_plugin/dune_action_test.ml @@ -15,7 +15,8 @@ let%expect_test _ = read_file ~path:(Path.of_string "some_dir/some_file") |> map ~f:print_endline in Private.do_run action; - [%expect {| + [%expect + {| Hello from foo! |}] ;; @@ -26,7 +27,8 @@ let%expect_test _ = |> map ~f:(fun data -> String.concat "," data |> print_endline) in Private.do_run action; - [%expect {| + [%expect + {| some_file |}] ;; @@ -50,7 +52,8 @@ let%expect_test _ = read_file ~path:(Path.of_string "file_that_does_not_exist") |> map ~f:ignore in run_action_expect_throws action; - [%expect {| + [%expect + {| read_file: file_that_does_not_exist: No such file or directory |}] ;; 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 4cd084f9d33..b5e3b1a1b80 100644 --- a/test/expect-tests/dune_async_io/async_io_tests.ml +++ b/test/expect-tests/dune_async_io/async_io_tests.ml @@ -83,13 +83,13 @@ let%expect_test "cancel task" = let* task = Async_io.ready r `Read ~f:ignore in Fiber.fork_and_join_unit (fun () -> - Async_io.Task.await task - >>= function - | Ok () | Error (`Exn _) -> assert false - | Error `Cancelled -> - Unix.close w; - let+ () = Async_io.close r in - print_endline "successfully cancelled") + Async_io.Task.await task + >>= function + | Ok () | Error (`Exn _) -> assert false + | Error `Cancelled -> + Unix.close w; + let+ () = Async_io.close r in + print_endline "successfully cancelled") (fun () -> Async_io.Task.cancel task)); [%expect {| successfully cancelled |}] ;; diff --git a/test/expect-tests/dune_console/dune_console_tests.ml b/test/expect-tests/dune_console/dune_console_tests.ml index e2d21339576..d1083330c1f 100644 --- a/test/expect-tests/dune_console/dune_console_tests.ml +++ b/test/expect-tests/dune_console/dune_console_tests.ml @@ -85,7 +85,8 @@ let%expect_test "Status line clearing." = Console.Backend.set Console.Backend.dumb; test_status_line_clearing (module Console); escape [%expect.output]; - [%expect {| + [%expect + {| Here is a status line |}] ;; @@ -107,7 +108,8 @@ let%expect_test "Multi-line status line clearing." = Console.Backend.set Console.Backend.dumb; test_status_line_clearing_multiline (module Console); escape [%expect.output]; - [%expect {| + [%expect + {| Some multiline status @@ -120,7 +122,8 @@ let%expect_test "Status line overwriting." = Console.Backend.set Console.Backend.dumb; test_status_line_overwrite (module Console); escape [%expect.output]; - [%expect {| + [%expect + {| Here is a status line Here is another status line |}] @@ -146,7 +149,8 @@ let%expect_test "Status line clearing." = Console.Backend.set Console.Backend.progress; test_status_line_clearing (module Console); escape [%expect.output]; - [%expect {| + [%expect + {| Here is a status line\r \r |}] ;; @@ -170,7 +174,8 @@ let%expect_test "Multi-line status line clearing." = Console.Backend.set Console.Backend.progress; test_status_line_clearing_multiline (module Console); escape [%expect.output]; - [%expect {| + [%expect + {| Some multiline status diff --git a/test/expect-tests/dune_engine/action_to_sh_tests.ml b/test/expect-tests/dune_engine/action_to_sh_tests.ml index 16e86862651..f2ecfe4dccb 100644 --- a/test/expect-tests/dune_engine/action_to_sh_tests.ml +++ b/test/expect-tests/dune_engine/action_to_sh_tests.ml @@ -7,7 +7,8 @@ let print x = x |> Action_to_sh.pp |> Dune_tests_common.print let%expect_test "run" = Run ("my_program", Array.Immutable.of_array [| "my"; "-I"; "args" |]) |> print; - [%expect {| + [%expect + {| my_program my -I args |}] ;; @@ -23,7 +24,8 @@ let%expect_test "chdir" = let%expect_test "setenv" = Setenv ("FOO", "bar", Bash "echo Hello world") |> print; - [%expect {| + [%expect + {| FOO=bar; bash -e -u -o pipefail -c 'echo Hello world' |}] ;; @@ -32,7 +34,8 @@ let%expect_test "with-stdout-to" = Redirect_out (Action.Outputs.Stdout, "foo", Action.File_perm.Normal, Bash "echo Hello world") |> print; - [%expect {| + [%expect + {| bash -e -u -o pipefail -c 'echo Hello world' > foo |}] ;; @@ -40,7 +43,8 @@ let%expect_test "with-stderr-to" = Redirect_out (Action.Outputs.Stderr, "foo", Action.File_perm.Normal, Bash "echo Hello world") |> print; - [%expect {| + [%expect + {| bash -e -u -o pipefail -c 'echo Hello world' 2> foo |}] ;; @@ -72,19 +76,22 @@ let%expect_test "with-outputs-to executable" = let%expect_test "ignore stdout" = Ignore (Action.Outputs.Stdout, Bash "echo Hello world") |> print; - [%expect {| + [%expect + {| bash -e -u -o pipefail -c 'echo Hello world' > /dev/null |}] ;; let%expect_test "ignore stderr" = Ignore (Action.Outputs.Stderr, Bash "echo Hello world") |> print; - [%expect {| + [%expect + {| bash -e -u -o pipefail -c 'echo Hello world' 2> /dev/null |}] ;; let%expect_test "ignore outputs" = Ignore (Action.Outputs.Outputs, Bash "echo Hello world") |> print; - [%expect {| + [%expect + {| bash -e -u -o pipefail -c 'echo Hello world' &> /dev/null |}] ;; @@ -92,11 +99,13 @@ let%expect_test "with-stdin-from" = Redirect_in ( Action.Inputs.Stdin , "foo" - , Bash {| + , Bash + {| while read line; do echo $line done - |} ) + |} + ) |> print; [%expect {| @@ -111,10 +120,13 @@ let%expect_test "with-stdin-from" = (* TODO currently no special printing for with-accepted-exit-codes *) let%expect_test "with-accepted-exit-codes" = With_accepted_exit_codes - (Predicate_lang.of_list [ 0; 1; 123 ], Bash {| + ( Predicate_lang.of_list [ 0; 1; 123 ] + , Bash + {| echo Hello world exit 123 - |}) + |} + ) |> print; [%expect {| @@ -142,44 +154,51 @@ let%expect_test "concurrent" = let%expect_test "echo" = Echo [ "Hello"; "world" ] |> print; - [%expect {| + [%expect + {| echo -n Helloworld |}] ;; let%expect_test "write-file" = Write_file ("foo", Action.File_perm.Normal, "Hello world") |> print; - [%expect {| + [%expect + {| echo -n 'Hello world' > foo |}] ;; let%expect_test "write-file executable" = Write_file ("foo", Action.File_perm.Executable, "Hello world") |> print; - [%expect {| + [%expect + {| echo -n 'Hello world' > foo; chmod +x foo |}] ;; let%expect_test "cat" = Cat [ "foo" ] |> print; - [%expect {| + [%expect + {| cat foo |}] ;; let%expect_test "cat multiple" = Cat [ "foo"; "bar" ] |> print; - [%expect {| + [%expect + {| cat foo bar |}] ;; let%expect_test "copy" = Copy ("foo", "bar") |> print; - [%expect {| + [%expect + {| cp foo bar |}] ;; let%expect_test "bash" = Bash "echo Hello world" |> print; - [%expect {| + [%expect + {| bash -e -u -o pipefail -c 'echo Hello world' |}] ;; diff --git a/test/expect-tests/dune_file_tests.ml b/test/expect-tests/dune_file_tests.ml index 9cd1e14d853..e2e3b7b52b7 100644 --- a/test/expect-tests/dune_file_tests.ml +++ b/test/expect-tests/dune_file_tests.ml @@ -17,7 +17,8 @@ let test s = let%expect_test _ = (* Link modes can be read as a ( ) list *) test "(best exe)"; - [%expect {| + [%expect + {| Other { mode = best; kind = exe } |}] ;; @@ -25,35 +26,40 @@ Other { mode = best; kind = exe } let%expect_test _ = (* Some shortcuts also exist *) test "exe"; - [%expect {| + [%expect + {| Other { mode = best; kind = exe } |}] ;; let%expect_test _ = test "object"; - [%expect {| + [%expect + {| Other { mode = best; kind = object } |}] ;; let%expect_test _ = test "shared_object"; - [%expect {| + [%expect + {| Other { mode = best; kind = shared_object } |}] ;; let%expect_test _ = test "byte"; - [%expect {| + [%expect + {| Other { mode = byte; kind = exe } |}] ;; let%expect_test _ = test "native"; - [%expect {| + [%expect + {| Other { mode = native; kind = exe } |}] ;; @@ -64,7 +70,8 @@ let test l = Executables.Link_mode.encode l let%expect_test _ = (* In the general case, modes are serialized as a list *) test (Other { kind = Shared_object; mode = Byte }) |> Dune_lang.to_dyn |> print_dyn; - [%expect {| + [%expect + {| [ "byte"; "shared_object" ] |}] ;; @@ -72,7 +79,8 @@ let%expect_test _ = (* But the specialized ones are serialized in the minimal version *) let%expect_test _ = test Executables.Link_mode.exe |> Dune_lang.to_dyn |> print_dyn; - [%expect {| + [%expect + {| "exe" |}] ;; diff --git a/test/expect-tests/dune_file_watcher/dune_file_watcher_tests_linux.ml b/test/expect-tests/dune_file_watcher/dune_file_watcher_tests_linux.ml old mode 100755 new mode 100644 index 91c4f0aba94..b7a06a053b0 --- a/test/expect-tests/dune_file_watcher/dune_file_watcher_tests_linux.ml +++ b/test/expect-tests/dune_file_watcher/dune_file_watcher_tests_linux.ml @@ -27,10 +27,10 @@ let%expect_test _ = events_buffer := []; Some (List.map list ~f:(function - | Dune_file_watcher.Event.Sync _ -> assert false - | Queue_overflow -> assert false - | Fs_memo_event e -> e - | Watcher_terminated -> assert false))) + | Dune_file_watcher.Event.Sync _ -> assert false + | Queue_overflow -> assert false + | Fs_memo_event e -> e + | Watcher_terminated -> assert false))) in let print_events n = print_events ~try_to_get_events ~expected:n in (match Dune_file_watcher.add_watch watcher (Path.of_string ".") with diff --git a/test/expect-tests/dune_file_watcher/dune_file_watcher_tests_macos.ml b/test/expect-tests/dune_file_watcher/dune_file_watcher_tests_macos.ml index 0493d16b209..92138efa623 100644 --- a/test/expect-tests/dune_file_watcher/dune_file_watcher_tests_macos.ml +++ b/test/expect-tests/dune_file_watcher/dune_file_watcher_tests_macos.ml @@ -28,10 +28,10 @@ let%expect_test _ = events_buffer := []; Some (List.filter_map list ~f:(function - | Dune_file_watcher.Event.Sync _ -> None - | Queue_overflow -> assert false - | Fs_memo_event e -> Some e - | Watcher_terminated -> assert false))) + | Dune_file_watcher.Event.Sync _ -> None + | Queue_overflow -> assert false + | Fs_memo_event e -> Some e + | Watcher_terminated -> assert false))) in let print_events n = print_events ~try_to_get_events ~expected:n in Dune_file_watcher.wait_for_initial_watches_established_blocking watcher; diff --git a/test/expect-tests/dune_lang/sexp_tests.ml b/test/expect-tests/dune_lang/sexp_tests.ml index 2201760a264..e8c60db0230 100644 --- a/test/expect-tests/dune_lang/sexp_tests.ml +++ b/test/expect-tests/dune_lang/sexp_tests.ml @@ -6,7 +6,11 @@ let () = init () let print_loc ppf (_ : Loc.t) = Format.pp_print_string ppf "" let sexp = - lazy (Dune_lang.Parser.parse_string ~fname:"" ~mode:Single {| + lazy + (Dune_lang.Parser.parse_string + ~fname:"" + ~mode:Single + {| ((foo 1) (foo 2)) |}) @@ -19,7 +23,8 @@ let print_ast ast = let%expect_test _ = Lazy.force sexp |> print_ast; - [%expect {| + [%expect + {| ((foo 1) (foo 2)) |}] ;; @@ -32,7 +37,8 @@ let of_sexp = let%expect_test _ = (try ignore (parse of_sexp Univ_map.empty (Lazy.force sexp) : int) with | User_error.E msg -> User_message.print { msg with loc = None }); - [%expect {| + [%expect + {| Error: Field "foo" is present too many times |}] ;; @@ -41,7 +47,8 @@ let of_sexp : int list t = enter (fields (multi_field "foo" int)) let%expect_test _ = parse of_sexp Univ_map.empty (Lazy.force sexp) |> Dyn.(list int) |> print_dyn; - [%expect {| + [%expect + {| [ 1; 2 ] |}] ;; @@ -68,168 +75,192 @@ let parse s = let%expect_test _ = parse {| # ## x##y x||y a#b|c#d copy# |}; - [%expect {| + [%expect + {| Ok [ "#"; "##"; "x##y"; "x||y"; "a#b|c#d"; "copy#" ] |}] ;; let%expect_test _ = parse {|x #| comment |# y|}; - [%expect {| + [%expect + {| Ok [ "x"; "#|"; "comment"; "|#"; "y" ] |}] ;; let%expect_test _ = parse {|x#|y|}; - [%expect {| + [%expect + {| Ok [ "x#|y" ] |}] ;; let%expect_test _ = parse {|x|#y|}; - [%expect {| + [%expect + {| Ok [ "x|#y" ] |}] ;; let%expect_test _ = parse {|"\a"|}; - [%expect {| + [%expect + {| Error "unknown escape sequence" |}] ;; let%expect_test _ = parse {|"\%{x}"|}; - [%expect {| + [%expect + {| Ok [ "%{x}" ] |}] ;; let%expect_test _ = parse {|"$foo"|}; - [%expect {| + [%expect + {| Ok [ "$foo" ] |}] ;; let%expect_test _ = parse {|"%foo"|}; - [%expect {| + [%expect + {| Ok [ "%foo" ] |}] ;; let%expect_test _ = parse {|"bar%foo"|}; - [%expect {| + [%expect + {| Ok [ "bar%foo" ] |}] ;; let%expect_test _ = parse {|"bar$foo"|}; - [%expect {| + [%expect + {| Ok [ "bar$foo" ] |}] ;; let%expect_test _ = parse {|"%bar$foo%"|}; - [%expect {| + [%expect + {| Ok [ "%bar$foo%" ] |}] ;; let%expect_test _ = parse {|"$bar%foo%"|}; - [%expect {| + [%expect + {| Ok [ "$bar%foo%" ] |}] ;; let%expect_test _ = parse {|\${foo}|}; - [%expect {| + [%expect + {| Ok [ "\\${foo}" ] |}] ;; let%expect_test _ = parse {|\%{foo}|}; - [%expect {| + [%expect + {| Ok [ template "\\%{foo}" ] |}] ;; let%expect_test _ = parse {|\$bar%foo%|}; - [%expect {| + [%expect + {| Ok [ "\\$bar%foo%" ] |}] ;; let%expect_test _ = parse {|\$bar\%foo%|}; - [%expect {| + [%expect + {| Ok [ "\\$bar\\%foo%" ] |}] ;; let%expect_test _ = parse {|\$bar\%foo%{bar}|}; - [%expect {| + [%expect + {| Ok [ template "\\$bar\\%foo%{bar}" ] |}] ;; let%expect_test _ = parse {|"bar%{foo}"|}; - [%expect {| + [%expect + {| Ok [ template "\"bar%{foo}\"" ] |}] ;; let%expect_test _ = parse {|"bar\%{foo}"|}; - [%expect {| + [%expect + {| Ok [ "bar%{foo}" ] |}] ;; let%expect_test _ = parse {|bar%{foo}|}; - [%expect {| + [%expect + {| Ok [ template "bar%{foo}" ] |}] ;; let%expect_test _ = parse {|"bar%{foo}"|}; - [%expect {| + [%expect + {| Ok [ template "\"bar%{foo}\"" ] |}] ;; let%expect_test _ = parse {|"bar\%foo"|}; - [%expect {| + [%expect + {| Ok [ "bar%foo" ] |}] ;; let%expect_test _ = parse {|"\0000"|}; - [%expect {| + [%expect + {| Ok [ "\0000" ] |}] ;; let%expect_test _ = parse {|"\x000"|}; - [%expect {| + [%expect + {| Ok [ "\0000" ] |}] ;; @@ -294,7 +325,8 @@ let test syntax sexp = let%expect_test _ = test Dune (a "toto"); - [%expect {| + [%expect + {| (S (Dune, "toto"), Round_trip_success) |}] ;; @@ -328,14 +360,16 @@ let%expect_test _ = let%expect_test _ = (* This round trip failure is expected *) test Dune (tq [ Text "x%{" ]); - [%expect {| + [%expect + {| (S (Dune, template "\"x\\%{\""), Did_not_round_trip "x%{") |}] ;; let%expect_test _ = test Dune (tq [ Text "x%"; Text "{" ]); - [%expect {| + [%expect + {| (S (Dune, template "\"x\\%{\""), Did_not_round_trip "x%{") |}] ;; diff --git a/test/expect-tests/dune_patch/dune_patch_tests.ml b/test/expect-tests/dune_patch/dune_patch_tests.ml index bfea2e1e68c..e19538af575 100644 --- a/test/expect-tests/dune_patch/dune_patch_tests.ml +++ b/test/expect-tests/dune_patch/dune_patch_tests.ml @@ -169,14 +169,16 @@ let check path = let%expect_test "patching a file" = test [ "foo.ml", "This is wrong\n" ] ("foo.patch", basic); check "foo.ml"; - [%expect {| + [%expect + {| This is right |}] ;; let%expect_test "patching a file in a subdirectory" = test [ "dir/foo.ml", "This is wrong\n" ] ("foo.patch", subdirectory); check "dir/foo.ml"; - [%expect {| + [%expect + {| This is right |}] ;; @@ -185,14 +187,16 @@ let%expect_test "patching two files with a single patch" = [ "foo.ml", "This is wrong\n"; "dir/foo.ml", "This is wrong\n" ] ("foo.patch", combined); check "foo.ml"; - [%expect {| + [%expect + {| This is right |}] ;; let%expect_test "patching a new file" = test [] ("foo.patch", new_file); check "foo.ml"; - [%expect {| + [%expect + {| This is right |}] ;; @@ -239,7 +243,8 @@ let normalize_error_path s = let%expect_test "Using a patch from 'diff' with a timestamp" = test [ "foo.ml", "This is wrong\n" ] ("foo.patch", unified); check "foo.ml"; - [%expect {| + [%expect + {| This is right |}] ;; diff --git a/test/expect-tests/dune_pkg/fetch_tests.ml b/test/expect-tests/dune_pkg/fetch_tests.ml index 7a5497ae435..e546c05ab31 100644 --- a/test/expect-tests/dune_pkg/fetch_tests.ml +++ b/test/expect-tests/dune_pkg/fetch_tests.ml @@ -33,10 +33,10 @@ let serve_once ~filename = let thread = Thread.create (fun server -> - Http.Server.accept server ~f:(fun session -> - let () = Http.Server.accept_request session in - Http.Server.respond_file session ~file:filename); - Http.Server.stop server) + Http.Server.accept server ~f:(fun session -> + let () = Http.Server.accept_request session in + Http.Server.respond_file session ~file:filename); + Http.Server.stop server) server in port, thread @@ -145,7 +145,8 @@ let%expect_test "downloading, without any checksum" = run (download ~unpack:false ~port ~filename:"" ~target:(subdir destination)); Thread.join server; print_endline "Finished successfully, no checksum verification"; - [%expect {| + [%expect + {| Done downloading Finished successfully, no checksum verification |}] ;; diff --git a/test/expect-tests/dune_pkg/git_config.ml b/test/expect-tests/dune_pkg/git_config.ml index 850fedf896d..380acd09c17 100644 --- a/test/expect-tests/dune_pkg/git_config.ml +++ b/test/expect-tests/dune_pkg/git_config.ml @@ -17,7 +17,8 @@ let print_or_fail l = let%expect_test "parsing simple section" = let config = "foo.bar=baz" in print_or_fail config; - [%expect {| + [%expect + {| ("foo", None, "bar", "baz") |}] ;; @@ -25,7 +26,8 @@ let%expect_test "parsing simple section" = let%expect_test "parsing with arguments" = let config = "foo.bar.baz=qux" in print_or_fail config; - [%expect {| + [%expect + {| ("foo", Some "bar", "baz", "qux") |}] ;; @@ -33,7 +35,8 @@ let%expect_test "parsing with arguments" = let%expect_test "parsing with dots in name" = let config = "branch.compat-5.0-dune-2.9.remote=origin" in print_or_fail config; - [%expect {| + [%expect + {| ("branch", Some "compat-5.0-dune-2.9", "remote", "origin") |}] ;; diff --git a/test/expect-tests/dune_pkg/rev_store_tests.ml b/test/expect-tests/dune_pkg/rev_store_tests.ml index a0de0f0c8f8..15bb4af9779 100644 --- a/test/expect-tests/dune_pkg/rev_store_tests.ml +++ b/test/expect-tests/dune_pkg/rev_store_tests.ml @@ -59,7 +59,8 @@ let%expect_test "adding remotes" = >>| (function | Error _ -> print_endline "Unable to fetch revision" | Ok _ -> print_endline "successfully fetched revision")); - [%expect {| + [%expect + {| Successfully found remote successfully fetched revision |}] diff --git a/test/expect-tests/dune_pkg_outdated/dune_pkg_outdated_test.ml b/test/expect-tests/dune_pkg_outdated/dune_pkg_outdated_test.ml index e8a9b7cf79e..aaa3866e5f6 100644 --- a/test/expect-tests/dune_pkg_outdated/dune_pkg_outdated_test.ml +++ b/test/expect-tests/dune_pkg_outdated/dune_pkg_outdated_test.ml @@ -5,10 +5,10 @@ module Console = Dune_console [c]/[d] transitive dependencies. The total number of dependencies will be [b] + [d] of which [a] + [b] will be outdated. *) let dummy_results - number_of_immediate - total_number_of_immediate - number_of_transitive - total_number_of_transitive + number_of_immediate + total_number_of_immediate + number_of_transitive + total_number_of_transitive = List.init (total_number_of_immediate - number_of_immediate) ~f:(fun _ -> Dune_pkg_outdated.For_tests.package_is_best_candidate) @@ -51,11 +51,11 @@ let show_styles_of_line line = outdated. Depending on the value of [transitive] it may output a helper message. It will also prefix the lines with the style that has been applied. *) let test_message - ~transitive - number_of_immediate - total_number_of_immediate - number_of_transitive - total_number_of_transitive + ~transitive + number_of_immediate + total_number_of_immediate + number_of_transitive + total_number_of_transitive = let results = dummy_results @@ -117,10 +117,10 @@ let%expect_test "transitive helper message" = that [transitive] is true which means we will not output a helper message. It will also prefix the lines with the style that has been applied. *) let test - number_of_immediate - total_number_of_immediate - number_of_transitive - total_number_of_transitive + number_of_immediate + total_number_of_immediate + number_of_transitive + total_number_of_transitive = test_message ~transitive:true @@ -272,11 +272,11 @@ let%expect_test "some larger examples" = (* [test_entire_output a b c d] prints the message from before and also all the outdated packages the command will output. Unlike before we do not print style information. *) let test_entire_output - ~transitive - number_of_immediate - total_number_of_immediate - number_of_transitive - total_number_of_transitive + ~transitive + number_of_immediate + total_number_of_immediate + number_of_transitive + total_number_of_transitive = let results = dummy_results diff --git a/test/expect-tests/dune_rpc/dune_rpc_tests.ml b/test/expect-tests/dune_rpc/dune_rpc_tests.ml index b962b95c65a..3fe3f074858 100644 --- a/test/expect-tests/dune_rpc/dune_rpc_tests.ml +++ b/test/expect-tests/dune_rpc/dune_rpc_tests.ml @@ -107,7 +107,8 @@ let%expect_test "initialize scheduler with rpc" = Fiber.return ()) ~handler (); - [%expect {| + [%expect + {| client: connected. now terminating server: finished. |}] ;; @@ -127,11 +128,11 @@ let%expect_test "no methods in common" = ;; let simple_request - (type a b) - ?(version = 1) - ~method_ - (req : (a, Conv.values) Conv.t) - (resp : (b, Conv.values) Conv.t) + (type a b) + ?(version = 1) + ~method_ + (req : (a, Conv.values) Conv.t) + (resp : (b, Conv.values) Conv.t) = let v = Decl.Request.make_current_gen ~req ~resp ~version in Decl.Request.make ~method_ ~generations:[ v ] @@ -333,7 +334,8 @@ let%expect_test "client is newer than server" = } in test ~private_menu:[ Request add_v1_v2 ] ~init ~client ~handler (); - [%expect {| + [%expect + {| client: sending request client: 25 server: finished. |}] @@ -366,7 +368,8 @@ let%expect_test "client is older than server" = } in test ~private_menu:[ Request add_v1_only ] ~init ~client ~handler (); - [%expect {| + [%expect + {| client: sending request client: 50 server: finished. |}] @@ -506,13 +509,13 @@ let%test_module "long polling" = let* () = req () in Fiber.fork_and_join_unit (fun () -> - let* () = Fiber.Ivar.read ready_to_cancel in - printfn "client: cancelling"; - Client.Stream.cancel poller) + let* () = Fiber.Ivar.read ready_to_cancel in + printfn "client: cancelling"; + Client.Stream.cancel poller) (fun () -> - printfn "client: waiting for second value (that will never come)"; - let+ () = Fiber.fork_and_join_unit req (Fiber.Ivar.fill ready_to_cancel) in - printfn "client: finishing session") + printfn "client: waiting for second value (that will never come)"; + let+ () = Fiber.fork_and_join_unit req (Fiber.Ivar.fill ready_to_cancel) in + printfn "client: finishing session") in test ~init ~client ~handler ~private_menu:[ Poll sub_proc ] (); [%expect.unreachable] @@ -871,7 +874,8 @@ let%expect_test "sexp_for_digest" = let%expect_test "print digests for all public RPCs" = let open Dune_rpc_private in Decl.Request.print_generations Procedures.Public.ping; - [%expect {| + [%expect + {| Version 1: Request: Unit Response: Unit @@ -896,13 +900,15 @@ let%expect_test "print digests for all public RPCs" = Response: String |}]; Decl.Request.print_generations Procedures.Public.promote; - [%expect {| + [%expect + {| Version 1: Request: String Response: Unit |}]; Decl.Request.print_generations Procedures.Public.build_dir; - [%expect {| + [%expect + {| Version 1: Request: Unit Response: String diff --git a/test/expect-tests/dune_rpc_e2e/dune_rpc_diagnostics.ml b/test/expect-tests/dune_rpc_e2e/dune_rpc_diagnostics.ml index 625d70f1ef9..0f5421d0882 100644 --- a/test/expect-tests/dune_rpc_e2e/dune_rpc_diagnostics.ml +++ b/test/expect-tests/dune_rpc_e2e/dune_rpc_diagnostics.ml @@ -16,7 +16,8 @@ let%expect_test "turn on and shutdown" = printfn "shutting down")) in run test; - [%expect {| + [%expect + {| Building . Build . succeeded shutting down |}] @@ -122,7 +123,8 @@ let diagnostic_with_build setup target = let%expect_test "error in dune file" = diagnostic_with_build [ "dune", "(library (name foo))" ] "foo.cma"; - [%expect {| + [%expect + {| Building foo.cma Build foo.cma succeeded |}] @@ -485,10 +487,12 @@ let%expect_test "create and fix error" = files [ "dune", "(executable (name foo))"; "foo.ml", "let () = print_endline 123" ]; let* poll = poll_exn client Dune_rpc.Public.Sub.diagnostic in let* () = print_diagnostics poll in - [%expect {| + [%expect + {| |}]; let* () = dune_build client "./foo.exe" in - [%expect {| + [%expect + {| Building ./foo.exe Build ./foo.exe failed |}]; let* () = print_diagnostics poll in @@ -529,7 +533,8 @@ let%expect_test "create and fix error" = ] |}]; files [ "foo.ml", "let () = print_endline \"foo\"" ]; let* () = dune_build client "./foo.exe" in - [%expect {| + [%expect + {| Building ./foo.exe Build ./foo.exe succeeded |}]; let+ () = print_diagnostics poll in @@ -639,7 +644,8 @@ let%expect_test "promoting dune files" = promoted ) ]; let* () = dune_build client "(alias foo)" in - [%expect {| + [%expect + {| Building (alias foo) Build (alias foo) failed |}]; print_endline "attempting to promote"; @@ -684,10 +690,12 @@ let g = A.f files [ "dune", "(executable (name foo))"; "foo.ml", source ]; let* poll = poll_exn client Dune_rpc.Public.Sub.diagnostic in let* () = print_diagnostics poll in - [%expect {| + [%expect + {| |}]; let* () = dune_build client "./foo.exe" in - [%expect {| + [%expect + {| Building ./foo.exe Build ./foo.exe failed |}]; let+ () = print_diagnostics poll in diff --git a/test/expect-tests/dune_util/flock_tests.ml b/test/expect-tests/dune_util/flock_tests.ml index 82c38584443..9e2708ff314 100644 --- a/test/expect-tests/dune_util/flock_tests.ml +++ b/test/expect-tests/dune_util/flock_tests.ml @@ -12,7 +12,8 @@ let%expect_test "blocking lock" = | Ok () -> print_endline "released lock" | Error _ -> assert false); Unix.close fd; - [%expect {| + [%expect + {| acquiring lock acquired lock released lock |}] @@ -60,7 +61,8 @@ let%expect_test "double lock" = (match Flock.lock_non_block lock Exclusive with | Ok `Success -> print_endline "lock 2 worked" | _ -> assert false); - [%expect {| + [%expect + {| lock 1 worked lock 2 worked |}] ;; diff --git a/test/expect-tests/fiber_event_bus/fiber_event_bus_tests.ml b/test/expect-tests/fiber_event_bus/fiber_event_bus_tests.ml index 0eea3cf01a9..f4db708d31e 100644 --- a/test/expect-tests/fiber_event_bus/fiber_event_bus_tests.ml +++ b/test/expect-tests/fiber_event_bus/fiber_event_bus_tests.ml @@ -61,7 +61,8 @@ let%expect_test "Double close" = let* () = close event_bus in let* () = close event_bus in Fiber.return ()); - [%expect {| + [%expect + {| Created bus. Closed bus. Closed bus. |}] @@ -73,7 +74,8 @@ let%expect_test "Push together with delayed close should close bus and block pus let* () = push event_bus "Hello" and* () = Test_scheduler.yield scheduler >>> close event_bus in Fiber.return ()); - [%expect {| + [%expect + {| Created bus. Closed bus. Couldn't push! Bus was closed. |}] @@ -85,7 +87,8 @@ let%expect_test "Pop together with delayed close should close bus and block pop. let* () = pop event_bus and* () = Test_scheduler.yield scheduler >>> close event_bus in Fiber.return ()); - [%expect {| + [%expect + {| Created bus. Closed bus. Couldn't pop! Bus was closed. |}] diff --git a/test/expect-tests/findlib_tests.ml b/test/expect-tests/findlib_tests.ml index becc9be0e5f..9cdab29bfe9 100644 --- a/test/expect-tests/findlib_tests.ml +++ b/test/expect-tests/findlib_tests.ml @@ -15,10 +15,12 @@ open Dune_tests_common let () = init () -let foo_meta = {| +let foo_meta = + {| requires = "bar" requires(ppx_driver) = "baz" |} +;; let db_path : Path.Outside_build_dir.t = External (Path.External.of_filename_relative_to_initial_cwd "../unit-tests/findlib-db") @@ -113,7 +115,8 @@ let%expect_test "configurator" = let%expect_test "builtins" = print_pkg_archives "str"; - [%expect {| + [%expect + {| Available { byte = []; native = [] } |}]; print_pkg_archives "dynlink"; [%expect diff --git a/test/expect-tests/fsevents/fsevents_tests.ml b/test/expect-tests/fsevents/fsevents_tests.ml index 888f5f661e3..2b17b160791 100644 --- a/test/expect-tests/fsevents/fsevents_tests.ml +++ b/test/expect-tests/fsevents/fsevents_tests.ml @@ -188,22 +188,22 @@ let test_with_multiple_fsevents ~setup ~test:f = let (t : Thread.t) = Thread.create (fun () -> - let rec await ~emit ~continue = function - | [] -> () - | xs -> - List.iter xs ~f:emit; - Unix.sleepf 0.2; - await ~emit ~continue (List.filter xs ~f:continue) - in - await - ~emit:(fun sync -> sync#emit_start) - ~continue:(fun sync -> not sync#started) - syncs; - f (); - await - ~emit:(fun sync -> sync#emit_stop) - ~continue:(fun sync -> not sync#stopped) - syncs) + let rec await ~emit ~continue = function + | [] -> () + | xs -> + List.iter xs ~f:emit; + Unix.sleepf 0.2; + await ~emit ~continue (List.filter xs ~f:continue) + in + await + ~emit:(fun sync -> sync#emit_start) + ~continue:(fun sync -> not sync#started) + syncs; + f (); + await + ~emit:(fun sync -> sync#emit_stop) + ~continue:(fun sync -> not sync#stopped) + syncs) () in (match Fsevents.Dispatch_queue.wait_until_stopped dispatch_queue with @@ -230,7 +230,8 @@ let test_with_operations ?on_event ?exclusion_paths f = let%expect_test "file create event" = test_with_operations (fun () -> Io.String_path.write_file "./file" "foobar"); - [%expect {| + [%expect + {| > { action = "Create"; kind = "File"; path = "$TESTCASE_ROOT/file" } |}] ;; @@ -257,12 +258,13 @@ let%expect_test "raise inside callback" = Logger.printfn logger "exiting."; raise Exit) (fun () -> - Io.String_path.write_file "old" "foobar"; - Io.String_path.write_file "old" "foobar"; - (* Delay to allow the event handler callback to catch the exception + Io.String_path.write_file "old" "foobar"; + Io.String_path.write_file "old" "foobar"; + (* Delay to allow the event handler callback to catch the exception before stopping the watcher. *) - Unix.sleepf 1.0); - [%expect {| + Unix.sleepf 1.0); + [%expect + {| [EXIT] exiting. |}] ;; @@ -273,8 +275,8 @@ let%expect_test "set exclusion paths" = test_with_operations ~exclusion_paths:(fun cwd -> [ paths cwd ignored ]) (fun () -> - let (_ : Fpath.mkdir_p_result) = Fpath.mkdir_p ignored in - Io.String_path.write_file (Filename.concat ignored "old") "foobar") + let (_ : Fpath.mkdir_p_result) = Fpath.mkdir_p ignored in + Io.String_path.write_file (Filename.concat ignored "old") "foobar") in (* absolute paths work *) run Filename.concat; diff --git a/test/expect-tests/memo/graph_dump/dump_graph_tests.ml b/test/expect-tests/memo/graph_dump/dump_graph_tests.ml index a847eba1e38..48ebd297a9d 100644 --- a/test/expect-tests/memo/graph_dump/dump_graph_tests.ml +++ b/test/expect-tests/memo/graph_dump/dump_graph_tests.ml @@ -23,8 +23,8 @@ let b = "B" ~input:(module Unit) (fun () -> - let+ () = Memo.exec a () in - ()) + let+ () = Memo.exec a () in + ()) ;; let c = @@ -32,8 +32,8 @@ let c = "C" ~input:(module Unit) (fun () -> - let+ () = Memo.exec a () in - ()) + let+ () = Memo.exec a () in + ()) ;; let d = @@ -41,9 +41,9 @@ let d = "D" ~input:(module Unit) (fun () -> - let* () = Memo.exec b () in - let+ () = Memo.exec c () in - ()) + let* () = Memo.exec b () in + let+ () = Memo.exec c () in + ()) ;; let e = @@ -51,8 +51,8 @@ let e = "E" ~input:(module Unit) (fun () -> - let* () = Memo.exec d () in - failwith "Oops, error!") + let* () = Memo.exec d () in + failwith "Oops, error!") ;; let () = run_memo e () diff --git a/test/expect-tests/memo/main.ml b/test/expect-tests/memo/main.ml index 6c4776a7242..3fdfff8175e 100644 --- a/test/expect-tests/memo/main.ml +++ b/test/expect-tests/memo/main.ml @@ -73,7 +73,8 @@ let%expect_test _ = Format.printf "%d@." !counter; print_endline (run_memo mcomp "a"); Format.printf "%d@." !counter; - [%expect {| + [%expect + {| 0 aaa 1 @@ -91,7 +92,8 @@ let print_deps memo input = let%expect_test _ = print_deps mcomp "a"; - [%expect {| + [%expect + {| Some [ (Some "some", "a"); (Some "another", "aa") ] |}] ;; @@ -103,7 +105,8 @@ let%expect_test _ = Format.printf "%d@." !counter; print_endline (run_memo mcomp "hello"); Format.printf "%d@." !counter; - [%expect {| + [%expect + {| hel 2 hel @@ -118,7 +121,8 @@ let%expect_test _ = Format.printf "%d@." !counter; print_endline (run_memo mcomp "hello"); Format.printf "%d@." !counter; - [%expect {| + [%expect + {| testtesttesttest hel 2 @@ -203,7 +207,8 @@ let%expect_test _ = Format.printf "%d@." !counter; Format.printf "%d@." (run_memo mfib 1800); Format.printf "%d@." !counter; - [%expect {| + [%expect + {| 2406280077793834213 2001 3080005411477819488 @@ -247,8 +252,8 @@ struct "f1" ~input:(module String) (fun s -> - let+ s = lazy_memo s >>= Lazy.force in - "f1: " ^ s) + let+ s = lazy_memo s >>= Lazy.force in + "f1: " ^ s) in f, Memo.exec f ;; @@ -259,8 +264,8 @@ struct "f2" ~input:(module String) (fun s -> - let+ s = lazy_memo s >>= Lazy.force in - "f2: " ^ s) + let+ s = lazy_memo s >>= Lazy.force in + "f2: " ^ s) in f, Memo.exec f ;; @@ -291,7 +296,8 @@ module Builtin_lazy = Test_lazy (struct let%expect_test _ = Builtin_lazy.run () |> Dyn.(pair string string) |> print_dyn; - [%expect {| + [%expect + {| ("f1: lazy: foo", "f2: lazy: foo") |}] ;; @@ -321,7 +327,8 @@ module Memo_lazy = Test_lazy (struct let%expect_test _ = Memo_lazy.run () |> Dyn.(pair string string) |> print_dyn; - [%expect {| + [%expect + {| ("f1: lazy: foo", "f2: lazy: foo") |}] ;; @@ -343,8 +350,8 @@ let depends_on_run = ~input:(module Unit) ~cutoff:Unit.equal (fun () -> - let+ (_ : Memo.Run.t) = Memo.current_run () in - print_endline "running foobar") + let+ (_ : Memo.Run.t) = Memo.current_run () in + print_endline "running foobar") ;; let%expect_test _ = @@ -353,7 +360,8 @@ let%expect_test _ = print_endline "resetting memo"; Memo.reset Memo.Invalidation.empty; run (Memo.exec depends_on_run ()); - [%expect {| + [%expect + {| running foobar resetting memo running foobar |}] @@ -367,7 +375,8 @@ let%expect_test _ = let cell = Memo.cell memo "foobar" in print_endline (run (Memo.Cell.read cell)); print_endline (run (Memo.Cell.read cell)); - [%expect {| + [%expect + {| *foobar *foobar |}] ;; @@ -1141,11 +1150,11 @@ let%expect_test "No deadlocks when creating the same cycle twice" = "summit" ~input:(module Int) (fun offset -> - printf "Started evaluating summit\n"; - let+ middle = Memo.exec middle () in - let result = middle + offset in - printf "Miraculously evaluated summit: %d\n" result; - result) + printf "Started evaluating summit\n"; + let+ middle = Memo.exec middle () in + let result = middle + offset in + printf "Miraculously evaluated summit: %d\n" result; + result) in evaluate_and_print summit 0; evaluate_and_print summit 1; @@ -1240,25 +1249,25 @@ let%expect_test "Nested nodes with cutoff are recomputed optimally" = "summit" ~input:(module Int) (fun offset -> - printf "Started evaluating summit\n"; - let middle = - create ~with_cutoff:false "middle" (fun () -> - printf "Started evaluating middle\n"; - let base = - create ~with_cutoff:false "base" (fun () -> - printf "Started evaluating base\n"; - let+ result = Memo.exec counter () in - printf "Evaluated middle: %d\n" result; - result) - in - let+ result = Memo.exec base () in - printf "Evaluated middle: %d\n" result; - result) - in - let+ middle = Memo.exec middle () in - let result = middle + offset in - printf "Evaluated summit: %d\n" result; - result) + printf "Started evaluating summit\n"; + let middle = + create ~with_cutoff:false "middle" (fun () -> + printf "Started evaluating middle\n"; + let base = + create ~with_cutoff:false "base" (fun () -> + printf "Started evaluating base\n"; + let+ result = Memo.exec counter () in + printf "Evaluated middle: %d\n" result; + result) + in + let+ result = Memo.exec base () in + printf "Evaluated middle: %d\n" result; + result) + in + let+ middle = Memo.exec middle () in + let result = middle + offset in + printf "Evaluated summit: %d\n" result; + result) in Memo.Metrics.reset (); evaluate_and_print summit 0; @@ -1331,22 +1340,22 @@ let%expect_test "Test that there are no phantom dependencies" = "summit" ~input:(module Int) (fun offset -> - printf "Started evaluating summit\n"; - let middle = - create ~with_cutoff:false "middle" (fun () -> - incr counter; - match !counter with - | 1 -> - printf "*** middle depends on base ***\n"; - Memo.Cell.read cell - | _ -> - printf "*** middle does not depend on base ***\n"; - Memo.return 0) - in - let+ middle = Memo.exec middle () in - let result = middle + offset in - printf "Evaluated summit: %d\n" result; - result) + printf "Started evaluating summit\n"; + let middle = + create ~with_cutoff:false "middle" (fun () -> + incr counter; + match !counter with + | 1 -> + printf "*** middle depends on base ***\n"; + Memo.Cell.read cell + | _ -> + printf "*** middle does not depend on base ***\n"; + Memo.return 0) + in + let+ middle = Memo.exec middle () in + let result = middle + offset in + printf "Evaluated summit: %d\n" result; + result) in evaluate_and_print summit 0; print_metrics (); @@ -1408,35 +1417,35 @@ let%expect_test "Abandoned node with no cutoff is recomputed" = "middle" ~input:(module Unit) (fun () -> - printf "Started evaluating middle\n"; - let base = base () in - last_created_base := Some base; - let+ result = Memo.exec base () in - printf "Evaluated middle: %d\n" result; - result) + printf "Started evaluating middle\n"; + let base = base () in + last_created_base := Some base; + let+ result = Memo.exec base () in + printf "Evaluated middle: %d\n" result; + result) in let summit = Memo.create "summit" ~input:(module Int) (fun input -> - printf "Started evaluating summit\n"; - let* middle = Memo.exec middle () in - let+ result = - match middle with - | 1 -> - printf "*** Captured last base ***\n"; - captured_base := !last_created_base; - Memo.exec (Option.value_exn !captured_base) () - | 2 -> - printf "*** Abandoned captured base ***\n"; - Memo.return input - | _ -> - printf "*** Recalled captured base ***\n"; - Memo.exec (Option.value_exn !captured_base) () - in - printf "Evaluated summit: %d\n" result; - result) + printf "Started evaluating summit\n"; + let* middle = Memo.exec middle () in + let+ result = + match middle with + | 1 -> + printf "*** Captured last base ***\n"; + captured_base := !last_created_base; + Memo.exec (Option.value_exn !captured_base) () + | 2 -> + printf "*** Abandoned captured base ***\n"; + Memo.return input + | _ -> + printf "*** Recalled captured base ***\n"; + Memo.exec (Option.value_exn !captured_base) () + in + printf "Evaluated summit: %d\n" result; + result) in Memo.reset Memo.Invalidation.empty; evaluate_and_print summit 0; @@ -1526,17 +1535,20 @@ let%expect_test "error handling with diamonds" = (fun () -> Memo.exec f (x - 1))); let test x = print_exns (fun () -> Memo.exec f x) in test 0; - [%expect {| + [%expect + {| Calling f 0 Error [ "Failure(\"reached 0\")" ] |}]; test 1; - [%expect {| + [%expect + {| Calling f 1 Error [ "Failure(\"reached 0\")" ] |}]; test 2; - [%expect {| + [%expect + {| Calling f 2 Error [ "Failure(\"reached 0\")" ] |}] @@ -1583,12 +1595,12 @@ let%expect_test "reproducible errors are cached" = "area of a square" ~input:(module Int) (fun x -> - printf "Started evaluating %d\n" x; - if x < 0 then failwith (sprintf "Negative input %d" x); - if x = 0 then raise (Memo.Non_reproducible (Failure "Zero input")); - let res = x * x in - printf "Evaluated %d: %d\n" x res; - Memo.return res) + printf "Started evaluating %d\n" x; + if x < 0 then failwith (sprintf "Negative input %d" x); + if x = 0 then raise (Memo.Non_reproducible (Failure "Zero input")); + let res = x * x in + printf "Evaluated %d: %d\n" x res; + Memo.return res) in Memo.Metrics.reset (); evaluate_and_print f 5; @@ -1658,25 +1670,25 @@ let%expect_test "errors work with early cutoff" = ~input:(module Int) ~cutoff:Int.equal (fun x -> - let+ run = Memo.current_run () in - printf "[divide] Started evaluating %d\n" x; - if x > 100 - then - (* This exception will be different in each run. *) - raise (Input_too_large run); - let res = 100 / x in - printf "[divide] Evaluated %d: %d\n" x res; - res) + let+ run = Memo.current_run () in + printf "[divide] Started evaluating %d\n" x; + if x > 100 + then + (* This exception will be different in each run. *) + raise (Input_too_large run); + let res = 100 / x in + printf "[divide] Evaluated %d: %d\n" x res; + res) in let f = Memo.create "Negate" ~input:(module Int) (fun x -> - printf "[negate] Started evaluating %d\n" x; - let+ res = Memo.exec divide x >>| Stdlib.Int.neg in - printf "[negate] Evaluated %d: %d\n" x res; - res) + printf "[negate] Started evaluating %d\n" x; + let+ res = Memo.exec divide x >>| Stdlib.Int.neg in + printf "[negate] Evaluated %d: %d\n" x res; + res) in Memo.Metrics.reset (); evaluate_and_print f 0; @@ -1737,18 +1749,18 @@ let%expect_test "Test that there are no spurious cycles" = "A" ~input:(module Int) (fun _input -> - printf "Started evaluating A\n"; - let+ result = - match !memory_a with - | 0 -> - let+ b = Memo.exec (Fdecl.get task_b_fdecl) 0 in - b + 1 - | _ -> Memo.return 0 - in - incr memory_a; - printf "A = %d\n" result; - printf "Evaluated A\n"; - result) + printf "Started evaluating A\n"; + let+ result = + match !memory_a with + | 0 -> + let+ b = Memo.exec (Fdecl.get task_b_fdecl) 0 in + b + 1 + | _ -> Memo.return 0 + in + incr memory_a; + printf "A = %d\n" result; + printf "Evaluated A\n"; + result) in let task_b = let memory_b = ref 0 in @@ -1757,18 +1769,18 @@ let%expect_test "Test that there are no spurious cycles" = ~input:(module Int) ~cutoff:Int.equal (fun _input -> - printf "Started evaluating B\n"; - let+ result = - match !memory_b with - | 0 -> Memo.return 0 - | _ -> - let+ a = Memo.exec task_a 0 in - a + 1 - in - incr memory_b; - printf "B = %d\n" result; - printf "Evaluated B\n"; - result) + printf "Started evaluating B\n"; + let+ result = + match !memory_b with + | 0 -> Memo.return 0 + | _ -> + let+ a = Memo.exec task_a 0 in + a + 1 + in + incr memory_b; + printf "B = %d\n" result; + printf "Evaluated B\n"; + result) in Fdecl.set task_b_fdecl task_b; Memo.Metrics.reset (); @@ -1824,18 +1836,18 @@ let%expect_test "Test Memo.clear_cache" = "Add 1" ~input:(module Int) (fun input -> - let result = input + 1 in - printf "Evaluated add_one(%d)\n" input; - Memo.return result) + let result = input + 1 in + printf "Evaluated add_one(%d)\n" input; + Memo.return result) in let add_two = Memo.create "Add 2" ~input:(module Int) (fun input -> - let+ result = Memo.exec add_one input in - printf "Evaluated add_two(%d)\n" input; - result + 1) + let+ result = Memo.exec add_one input in + printf "Evaluated add_two(%d)\n" input; + result + 1) in Memo.Metrics.reset (); evaluate_and_print add_one 1; @@ -1909,11 +1921,11 @@ let%expect_test "restore_from_cache and compute phases are well-separated" = "C" ~input:(module Int) (fun input -> - printf "Started evaluating C\n"; - let* () = Memo.of_reproducible_fiber (Fiber.of_thunk Scheduler.yield) in - let+ (_ : Memo.Run.t) = Memo.current_run () in - printf "Evaluated C\n"; - input + 1) + printf "Started evaluating C\n"; + let* () = Memo.of_reproducible_fiber (Fiber.of_thunk Scheduler.yield) in + let+ (_ : Memo.Run.t) = Memo.current_run () in + printf "Evaluated C\n"; + input + 1) in let task_x_fdecl = Fdecl.create (fun _ -> Dyn.Opaque) in let task_b = @@ -1922,16 +1934,16 @@ let%expect_test "restore_from_cache and compute phases are well-separated" = "B" ~input:(module Int) (fun input -> - printf "Started evaluating B\n"; - let+ result = - match !memory_b with - | 0 -> Memo.exec task_c input - | _ -> Memo.exec (Fdecl.get task_x_fdecl) input - in - incr memory_b; - printf "B = %d\n" result; - printf "Evaluated B\n"; - result) + printf "Started evaluating B\n"; + let+ result = + match !memory_b with + | 0 -> Memo.exec task_c input + | _ -> Memo.exec (Fdecl.get task_x_fdecl) input + in + incr memory_b; + printf "B = %d\n" result; + printf "Evaluated B\n"; + result) in let task_a = let memory_a = ref 0 in @@ -1939,26 +1951,26 @@ let%expect_test "restore_from_cache and compute phases are well-separated" = "A" ~input:(module Int) (fun input -> - printf "Started evaluating A\n"; - let+ result = - match !memory_a with - | 0 -> Memo.exec task_b input - | _ -> Memo.exec (Fdecl.get task_x_fdecl) input - in - incr memory_a; - printf "A = %d\n" result; - printf "Evaluated A\n"; - result) + printf "Started evaluating A\n"; + let+ result = + match !memory_a with + | 0 -> Memo.exec task_b input + | _ -> Memo.exec (Fdecl.get task_x_fdecl) input + in + incr memory_a; + printf "A = %d\n" result; + printf "Evaluated A\n"; + result) in let task_x = Memo.create "X" ~input:(module Int) (fun input -> - printf "Started evaluating X\n"; - let+ result = Memo.exec task_b input in - printf "Evaluated X\n"; - result) + printf "Started evaluating X\n"; + let+ result = Memo.exec task_b input in + printf "Evaluated X\n"; + result) in Fdecl.set task_x_fdecl task_x; Memo.Metrics.reset (); @@ -2017,16 +2029,16 @@ let%expect_test "Simple computation chain with a cutoff" = ~cutoff:Int.equal ~input:(module Int) (fun x -> - printf "Started evaluating f(%d)\n" x; - let+ res = - match x with - | 0 -> Memo.return 0 - | n -> - let+ prev = Memo.exec (Fdecl.get f) (n - 1) in - prev + 1 - in - printf "Evaluated f(%d) = %d\n" x res; - res) + printf "Started evaluating f(%d)\n" x; + let+ res = + match x with + | 0 -> Memo.return 0 + | n -> + let+ prev = Memo.exec (Fdecl.get f) (n - 1) in + prev + 1 + in + printf "Evaluated f(%d) = %d\n" x res; + res) in Fdecl.set f f_impl; let f = Fdecl.get f in @@ -2083,7 +2095,8 @@ let%expect_test "loss of concurrency" = let read x = run @@ Memo.map ~f:ignore @@ Memo.Cell.read x in (* First we evaluate everything. Note that [a] and [b] are evalauted concurrently *) read c; - [%expect {| + [%expect + {| start a start b finish a @@ -2095,7 +2108,8 @@ let%expect_test "loss of concurrency" = (Memo.Cell.invalidate b ~reason:Test)); (* Now we recompute [c]. Notice that [a] and [b] are no longer computed concurrently *) read c; - [%expect {| + [%expect + {| start a finish a start b @@ -2117,7 +2131,8 @@ let%expect_test "variables - invalidation" = Memo.Invalidation.details_hum invalidation |> String.concat ~sep:"\n" |> print_endline; Memo.reset invalidation; run (); - [%expect {| + [%expect + {| Variable foo changed var: 400 |}] ;; diff --git a/test/expect-tests/memo/run_with_error_handler.ml b/test/expect-tests/memo/run_with_error_handler.ml index 58697909a58..3cd8c318586 100644 --- a/test/expect-tests/memo/run_with_error_handler.ml +++ b/test/expect-tests/memo/run_with_error_handler.ml @@ -42,9 +42,9 @@ let%expect_test "Memo.run_with_error_handler" = log "late"; Fiber.return ()) (fun () -> - Memo.run_with_error_handler m ~handle_error_no_raise:(fun _exn -> - log "early"; - Fiber.return ()))) + Memo.run_with_error_handler m ~handle_error_no_raise:(fun _exn -> + log "early"; + Fiber.return ()))) ~f:(fun _result -> !trace) in let trace1, trace2 = @@ -58,7 +58,8 @@ let%expect_test "Memo.run_with_error_handler" = in print_trace trace1; print_trace trace2; - [%expect {| + [%expect + {| early@0 late@10 early@10 diff --git a/test/expect-tests/scheduler_tests.ml b/test/expect-tests/scheduler_tests.ml index 4df02d62f12..ee142be4fcd 100644 --- a/test/expect-tests/scheduler_tests.ml +++ b/test/expect-tests/scheduler_tests.ml @@ -35,27 +35,27 @@ let%expect_test "cancelling a build" = go (fun () -> Fiber.fork_and_join_unit (fun () -> - Scheduler.Run.poll - (let* () = Fiber.Ivar.fill build_started () in - let* () = Fiber.Ivar.read build_cancelled in - let* res = - Fiber.collect_errors (fun () -> - Scheduler.with_job_slot (fun _ _ -> Fiber.return ())) - in - print_endline - (match res with - | Ok () -> "FAIL: build wasn't cancelled" - | Error _ -> "PASS: build was cancelled"); - let* () = Scheduler.shutdown () in - Fiber.never)) + Scheduler.Run.poll + (let* () = Fiber.Ivar.fill build_started () in + let* () = Fiber.Ivar.read build_cancelled in + let* res = + Fiber.collect_errors (fun () -> + Scheduler.with_job_slot (fun _ _ -> Fiber.return ())) + in + print_endline + (match res with + | Ok () -> "FAIL: build wasn't cancelled" + | Error _ -> "PASS: build was cancelled"); + let* () = Scheduler.shutdown () in + Fiber.never)) (fun () -> - let* () = Fiber.Ivar.read build_started in - let* () = - Scheduler.inject_memo_invalidation (Memo.Cell.invalidate cell ~reason:Unknown) - in - (* Wait for the scheduler to acknowledge the change *) - let* () = Scheduler.wait_for_build_input_change () in - Fiber.Ivar.fill build_cancelled ())); + let* () = Fiber.Ivar.read build_started in + let* () = + Scheduler.inject_memo_invalidation (Memo.Cell.invalidate cell ~reason:Unknown) + in + (* Wait for the scheduler to acknowledge the change *) + let* () = Scheduler.wait_for_build_input_change () in + Fiber.Ivar.fill build_cancelled ())); [%expect {| PASS: build was cancelled |}] ;; @@ -66,21 +66,21 @@ let%expect_test "cancelling a build: effect on other fibers" = go (fun () -> Fiber.fork_and_join_unit (fun () -> - Scheduler.Run.poll - (let* () = Fiber.Ivar.fill build_started () in - Fiber.never)) + Scheduler.Run.poll + (let* () = Fiber.Ivar.fill build_started () in + Fiber.never)) (fun () -> - let* () = Fiber.Ivar.read build_started in - let* () = - 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 () -> Fiber.return ()) in - print_endline - (match res with - | Ok () -> "PASS: we can still run things outside the build" - | Error _ -> "FAIL: other fiber got cancelled"); - Scheduler.shutdown ())); + let* () = Fiber.Ivar.read build_started in + let* () = + 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 () -> Fiber.return ()) in + print_endline + (match res with + | Ok () -> "PASS: we can still run things outside the build" + | Error _ -> "FAIL: other fiber got cancelled"); + Scheduler.shutdown ())); [%expect {| PASS: we can still run things outside the build |}] ;; @@ -90,8 +90,8 @@ let%expect_test "raise inside Scheduler.Run.go" = @@ fun () -> Fiber.fork_and_join_unit (fun () -> - print_endline "t1"; - Fiber.return ()) + print_endline "t1"; + Fiber.return ()) (fun () -> raise Exit)); assert false with diff --git a/test/expect-tests/scheme/scheme_tests.ml b/test/expect-tests/scheme/scheme_tests.ml index f9728669765..4216eb9a0f6 100644 --- a/test/expect-tests/scheme/scheme_tests.ml +++ b/test/expect-tests/scheme/scheme_tests.ml @@ -153,7 +153,8 @@ open Scheme let%expect_test _ = let scheme = Scheme.Thunk (fun () -> Memo.return Scheme.Empty) in print_rules scheme ~dir:(Path.of_string "foo/bar"); - [%expect {| + [%expect + {| calls: thunk rules: @@ -169,7 +170,8 @@ let scheme_all_but_foo_bar = let%expect_test _ = print_rules scheme_all_but_foo_bar ~dir:(Path.of_string "unrelated/dir"); - [%expect {| + [%expect + {| calls: t:thunk rules: diff --git a/test/expect-tests/timer_tests.ml b/test/expect-tests/timer_tests.ml index fc006ec317b..8e54815414b 100644 --- a/test/expect-tests/timer_tests.ml +++ b/test/expect-tests/timer_tests.ml @@ -16,12 +16,12 @@ let%expect_test "create and wait for timer" = ~on_event:(fun _ _ -> ()) config (fun () -> - let now () = Unix.gettimeofday () in - let start = now () in - let duration = 0.2 in - let+ () = Scheduler.sleep ~seconds:duration in - assert (now () -. start >= duration); - print_endline "timer finished successfully"); + let now () = Unix.gettimeofday () in + let start = now () in + let duration = 0.2 in + let+ () = Scheduler.sleep ~seconds:duration in + assert (now () -. start >= duration); + print_endline "timer finished successfully"); [%expect {| timer finished successfully |}] ;; @@ -30,11 +30,12 @@ let%expect_test "multiple timers" = ~on_event:(fun _ _ -> ()) config (fun () -> - [ 0.3; 0.2; 0.1 ] - |> Fiber.parallel_iter ~f:(fun duration -> - let+ () = Scheduler.sleep ~seconds:duration in - printfn "finished %0.2f" duration)); - [%expect {| + [ 0.3; 0.2; 0.1 ] + |> Fiber.parallel_iter ~f:(fun duration -> + let+ () = Scheduler.sleep ~seconds:duration in + printfn "finished %0.2f" duration)); + [%expect + {| finished 0.10 finished 0.20 finished 0.30 |}] @@ -45,15 +46,16 @@ let%expect_test "run process with timeout" = ~on_event:(fun _ _ -> ()) config (fun () -> - let pid = - let prog = - let path = Env.get Env.initial "PATH" |> Option.value_exn |> Bin.parse_path in - Bin.which ~path "sleep" |> Option.value_exn |> Path.to_string - in - Spawn.spawn ~prog ~argv:[ prog; "100000" ] () |> Pid.of_int - in - let+ _ = Scheduler.wait_for_process ~timeout_seconds:0.1 pid in - print_endline "sleep timed out"); - [%expect {| + let pid = + let prog = + let path = Env.get Env.initial "PATH" |> Option.value_exn |> Bin.parse_path in + Bin.which ~path "sleep" |> Option.value_exn |> Path.to_string + in + Spawn.spawn ~prog ~argv:[ prog; "100000" ] () |> Pid.of_int + in + let+ _ = Scheduler.wait_for_process ~timeout_seconds:0.1 pid in + print_endline "sleep timed out"); + [%expect + {| sleep timed out |}] ;; diff --git a/test/unit-tests/artifact_substitution/artifact_substitution.ml b/test/unit-tests/artifact_substitution/artifact_substitution.ml index 8da6dd01f3c..0dc2b101678 100644 --- a/test/unit-tests/artifact_substitution/artifact_substitution.ml +++ b/test/unit-tests/artifact_substitution/artifact_substitution.ml @@ -10,8 +10,8 @@ let () = let fail fmt = Printf.ksprintf (fun msg -> - prerr_endline msg; - exit 1) + prerr_endline msg; + exit 1) fmt ;;