From fe544973d3d564fbe43f34ac3fdaf9ad64e0f578 Mon Sep 17 00:00:00 2001 From: Antonio Nuno Monteiro Date: Wed, 31 May 2023 19:56:00 -0700 Subject: [PATCH 1/2] test(melange): demonstrate melange.emit doesn't respect `-p` Signed-off-by: Antonio Nuno Monteiro --- .../test-cases/melange/melange-emit-package.t | 49 +++++++++++++++++++ 1 file changed, 49 insertions(+) create mode 100644 test/blackbox-tests/test-cases/melange/melange-emit-package.t diff --git a/test/blackbox-tests/test-cases/melange/melange-emit-package.t b/test/blackbox-tests/test-cases/melange/melange-emit-package.t new file mode 100644 index 00000000000..e992ee395b7 --- /dev/null +++ b/test/blackbox-tests/test-cases/melange/melange-emit-package.t @@ -0,0 +1,49 @@ +Test that melange.emit targets are not included in @install for packages they +don't belong to. + + $ mkdir lib test ppx + $ cat > dune-project < (lang dune 3.8) + > (package (name my-ppx)) + > (package (name mel-foo)) + > (using melange 0.1) + > EOF + + $ cat > ppx/dune < (library + > (name my_ppx) + > (public_name my-ppx)) + > EOF + $ touch ppx/my_ppx.ml + + $ cat > lib/dune < (library + > (public_name mel-foo) + > (name mel_foo) + > (modes melange) + > (preprocess (pps melange.ppx))) + > EOF + $ cat > lib/mel_foo.ml < let x = "lib" + > EOF + + $ cat > test/dune < (melange.emit + > (package mel-foo) + > (target js-out) + > (emit_stdlib false) + > (libraries mel-foo)) + > EOF + $ cat > test/test_entry.ml < let () = Js.log Mel_foo.x + > EOF + +`melange.emit` is attached to the package `mel-foo`, so it shouldn't be built +when building the other library + + $ dune build -p my-ppx + File "test/dune", line 5, characters 12-19: + 5 | (libraries mel-foo)) + ^^^^^^^ + Error: Library "mel-foo" not found. + [1] From 6d52a6498e774fec27df016dd17aec5516f91797 Mon Sep 17 00:00:00 2001 From: Antonio Nuno Monteiro Date: Wed, 31 May 2023 20:04:52 -0700 Subject: [PATCH 2/2] fix(melange): resolve libraries lazily for melange.emit Signed-off-by: Antonio Nuno Monteiro Signed-off-by: Rudi Grinberg --- src/dune_rules/melange/melange_rules.ml | 72 ++++++++++++++----- src/dune_rules/resolve.ml | 12 ++-- src/dune_rules/resolve.mli | 4 ++ .../test-cases/melange/melange-emit-package.t | 48 ++++++++++++- 4 files changed, 112 insertions(+), 24 deletions(-) diff --git a/src/dune_rules/melange/melange_rules.ml b/src/dune_rules/melange/melange_rules.ml index 63f832e413e..4540add7765 100644 --- a/src/dune_rules/melange/melange_rules.ml +++ b/src/dune_rules/melange/melange_rules.ml @@ -336,8 +336,8 @@ let setup_runtime_assets_rules sctx ~dir ~target_dir ~mode ~output ~for_ mel = in () -let setup_entries_js ~sctx ~dir ~dir_contents ~scope ~compile_info ~target_dir - ~mode (mel : Melange_stanzas.Emit.t) = +let modules_for_js_and_obj_dir ~sctx ~dir_contents ~scope + (mel : Melange_stanzas.Emit.t) = let open Memo.O in (* Use "mobjs" rather than "objs" to avoid a potential conflict with a library of the same name *) @@ -345,7 +345,7 @@ let setup_entries_js ~sctx ~dir ~dir_contents ~scope ~compile_info ~target_dir Dir_contents.ocaml dir_contents >>| Ml_sources.modules_and_obj_dir ~for_:(Melange { target = mel.target }) in - let* modules = + let+ modules = let version = (Super_context.context sctx).ocaml.version in let* preprocess = Resolve.Memo.read_memo @@ -358,16 +358,24 @@ let setup_entries_js ~sctx ~dir ~dir_contents ~scope ~compile_info ~target_dir in Modules.map_user_written modules ~f:(fun m -> Memo.return @@ pped_map m) in + let modules_for_js = + Modules.fold_no_vlib modules ~init:[] ~f:(fun x acc -> + if Module.has x ~ml_kind:Impl then x :: acc else acc) + in + (modules_for_js, obj_dir) + +let setup_entries_js ~sctx ~dir ~dir_contents ~scope ~compile_info ~target_dir + ~mode (mel : Melange_stanzas.Emit.t) = + let open Memo.O in + let* modules_for_js, obj_dir = + modules_for_js_and_obj_dir ~sctx ~dir_contents ~scope mel + in let requires_link = Lib.Compile.requires_link compile_info in let pkg_name = Option.map mel.package ~f:Package.name in let loc = mel.loc in let module_systems = mel.module_systems in let* requires_link = Memo.Lazy.force requires_link in let includes = cmj_includes ~requires_link ~scope in - let modules_for_js = - Modules.fold_no_vlib modules ~init:[] ~f:(fun x acc -> - if Module.has x ~ml_kind:Impl then x :: acc else acc) - in let output = `Private_library_or_emit target_dir in let obj_dir = Obj_dir.of_local obj_dir in let* () = @@ -426,6 +434,18 @@ let setup_js_rules_libraries ~dir ~scope ~target_dir ~sctx ~requires_link ~mode let* source_modules = impl_only_modules_defined_in_this_lib sctx lib in Memo.parallel_iter source_modules ~f:(build_js ~dir ~output ~includes)) +let setup_js_rules_libraries_and_entries ~dir_contents ~dir ~scope ~sctx + ~compile_info ~requires_link ~mode ~target_dir mel = + let open Memo.O in + let+ () = + setup_js_rules_libraries ~dir ~scope ~target_dir ~sctx ~requires_link ~mode + mel + and+ () = + setup_entries_js ~sctx ~dir ~dir_contents ~scope ~compile_info ~target_dir + ~mode mel + in + () + let setup_emit_js_rules ~dir_contents ~dir ~scope ~sctx mel = let open Memo.O in let target_dir = @@ -437,15 +457,31 @@ let setup_emit_js_rules ~dir_contents ~dir ~scope ~sctx mel = | Some p -> Promote p in let* compile_info = compile_info ~scope mel in - let+ () = - let* requires_link = - Lib.Compile.requires_link compile_info - |> Memo.Lazy.force >>= Resolve.read_memo - in - setup_js_rules_libraries ~dir ~scope ~target_dir ~sctx ~requires_link ~mode - mel - and+ () = - setup_entries_js ~sctx ~dir ~dir_contents ~scope ~compile_info ~target_dir - ~mode mel + let* requires_link_resolve = + Lib.Compile.requires_link compile_info |> Memo.Lazy.force in - () + match Resolve.to_result requires_link_resolve with + | Ok requires_link -> + setup_js_rules_libraries_and_entries ~dir_contents ~dir ~scope ~sctx + ~compile_info ~requires_link ~mode ~target_dir mel + | Error resolve_error -> + (* NOTE: in multi-package projects where [melange.emit] stanzas are + present, we can't eagerly resolve the link-time closure for + [melange.emit] stanzas since their targets aren't public (i.e. part of a + package). When resolution fails, we replace the JS entries with the + resolution error inside [Action_builder.fail] to give Dune a chance to + fail if any of the targets end up attached to a package installation. *) + let* modules_for_js, _obj_dir = + modules_for_js_and_obj_dir ~sctx ~dir_contents ~scope mel + in + Resolve.push_frames resolve_error @@ fun () -> + let module_systems = mel.module_systems in + let output = `Private_library_or_emit target_dir in + let loc = mel.loc in + Memo.parallel_iter modules_for_js ~f:(fun m -> + Memo.parallel_iter module_systems ~f:(fun (_module_system, js_ext) -> + let file_targets = [ make_js_name ~output ~js_ext m ] in + Super_context.add_rule sctx ~dir ~loc ~mode + (Action_builder.fail + { fail = (fun () -> Resolve.raise_error resolve_error) } + |> Action_builder.with_file_targets ~file_targets))) diff --git a/src/dune_rules/resolve.ml b/src/dune_rules/resolve.ml index 057028173b6..67c4f151f46 100644 --- a/src/dune_rules/resolve.ml +++ b/src/dune_rules/resolve.ml @@ -41,12 +41,14 @@ let to_result x = x let of_error x = Error x -let error_to_memo { stack_frames; exn } = - let open Memo.O in +let raise_error ({ exn; _ } : error) = raise exn + +let push_frames { stack_frames; exn = _ } f = let rec loop = function | [] -> - let+ () = Memo.return () in - raise exn + let open Memo.O in + let* () = Memo.return () in + f () | x :: rest -> Memo.push_stack_frame ~human_readable_description:(fun () -> Lazy.force x) @@ -54,6 +56,8 @@ let error_to_memo { stack_frames; exn } = in loop stack_frames +let error_to_memo error = push_frames error (fun () -> raise_error error) + let read_memo = function | Ok x -> Memo.return x | Error err -> error_to_memo err diff --git a/src/dune_rules/resolve.mli b/src/dune_rules/resolve.mli index 87ad3938742..9472b161090 100644 --- a/src/dune_rules/resolve.mli +++ b/src/dune_rules/resolve.mli @@ -108,6 +108,10 @@ type error val to_result : 'a t -> ('a, error) result +val raise_error : error -> 'a + +val push_frames : error -> (unit -> 'a Memo.t) -> 'a Memo.t + val of_error : error -> 'a t (** Read a [Resolve.t] value inside the action builder monad. *) diff --git a/test/blackbox-tests/test-cases/melange/melange-emit-package.t b/test/blackbox-tests/test-cases/melange/melange-emit-package.t index e992ee395b7..175a9fd56a2 100644 --- a/test/blackbox-tests/test-cases/melange/melange-emit-package.t +++ b/test/blackbox-tests/test-cases/melange/melange-emit-package.t @@ -42,8 +42,52 @@ don't belong to. when building the other library $ dune build -p my-ppx - File "test/dune", line 5, characters 12-19: - 5 | (libraries mel-foo)) + +It still builds everything normally with the alias + + $ dune build @melange + $ ls _build/default/test/js-out/test/ + test_entry.js + +Now define a 3rd lib that we'll use to preprocess the melange.emit entries: + + $ dune clean + $ cat > dune-project < (lang dune 3.8) + > (package (name my-ppx)) + > (package (name mel-foo)) + > (package (name my-ppx2)) + > (using melange 0.1) + > EOF + $ mkdir ppx2 + $ cat > ppx2/dune < (library + > (name my_ppx2) + > (kind ppx_rewriter) (libraries ppxlib) + > (public_name my-ppx2)) + > EOF + $ touch ppx2/my_ppx2.ml + $ cat > test/dune < (melange.emit + > (package mel-foo) + > (target js-out) + > (preprocess (pps my-ppx2)) + > (emit_stdlib false) + > (libraries mel-foo)) + > EOF + +we can still build my-ppx independently + + $ dune build -p my-ppx + +and fails if it can't resolve libraries to build the alias + + $ dune build @melange -p my-ppx + File "test/dune", line 6, characters 12-19: + 6 | (libraries mel-foo)) ^^^^^^^ Error: Library "mel-foo" not found. + -> required by _build/default/test/js-out/test/test_entry.js + -> required by alias test/melange [1] +