diff --git a/bin/main.ml b/bin/main.ml index d9a8f494..21561f7e 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -659,75 +659,89 @@ let check_path contexts = name (hint name (String.Set.to_list contexts)) -let resolve_targets ~log common (setup : Main.setup) user_targets = +type resolve_input = + | Path of Path.t + | String of string + +let resolve_path path ~(setup : Main.setup) = + check_path setup.contexts path; + let can't_build path = + Error (path, target_hint setup path); + in + if not (Path.is_managed path) then + Ok [File path] + else if Path.is_in_build_dir path then begin + if Build_system.is_target setup.build_system path then + Ok [File path] + else + can't_build path + end else + match + List.filter_map setup.contexts ~f:(fun ctx -> + let path = Path.append ctx.Context.build_dir path in + if Build_system.is_target setup.build_system path then + Some (File path) + else + None) + with + | [] -> can't_build path + | l -> Ok l + +let resolve_target common ~(setup : Main.setup) s = + if String.is_prefix s ~prefix:"@" then begin + let pos, is_rec = + if String.length s >= 2 && s.[1] = '@' then + (2, false) + else + (1, true) + in + let s = String.sub s ~pos ~len:(String.length s - pos) in + let path = Path.relative Path.root (prefix_target common s) in + check_path setup.contexts path; + if Path.is_root path then + die "@@ on the command line must be followed by a valid alias name" + else if not (Path.is_managed path) then + die "@@ on the command line must be followed by a relative path" + else + Ok [if is_rec then Alias_rec path else Alias path] + end else begin + let path = Path.relative Path.root (prefix_target common s) in + resolve_path path ~setup + end + +let log_targets ~log targets = + List.iter targets ~f:(function + | File path -> + Log.info log @@ "- " ^ (Path.to_string path) + | Alias path -> + Log.info log @@ "- alias " ^ + (Path.to_string_maybe_quoted path) + | Alias_rec path -> + Log.info log @@ "- recursive alias " ^ + (Path.to_string_maybe_quoted path)); + flush stdout + +let resolve_targets_mixed ~log common (setup : Main.setup) user_targets = match user_targets with | [] -> [] | _ -> - let check_path = check_path setup.contexts in let targets = - List.map user_targets ~f:(fun s -> - if String.is_prefix s ~prefix:"@" then begin - let pos, is_rec = - if String.length s >= 2 && s.[1] = '@' then - (2, false) - else - (1, true) - in - let s = String.sub s ~pos ~len:(String.length s - pos) in - let path = Path.relative Path.root (prefix_target common s) in - check_path path; - if Path.is_root path then - die "@@ on the command line must be followed by a valid alias name" - else if not (Path.is_managed path) then - die "@@ on the command line must be followed by a relative path" - else - Ok [if is_rec then Alias_rec path else Alias path] - end else begin - let path = Path.relative Path.root (prefix_target common s) in - check_path path; - let can't_build path = - Error (path, target_hint setup path); - in - if not (Path.is_managed path) then - Ok [File path] - else if Path.is_in_build_dir path then begin - if Build_system.is_target setup.build_system path then - Ok [File path] - else - can't_build path - end else - match - List.filter_map setup.contexts ~f:(fun ctx -> - let path = Path.append ctx.Context.build_dir path in - if Build_system.is_target setup.build_system path then - Some (File path) - else - None) - with - | [] -> can't_build path - | l -> Ok l - end - ) - in + List.map user_targets ~f:(function + | String s -> resolve_target common ~setup s + | Path p -> resolve_path p ~setup) in if common.config.display = Verbose then begin Log.info log "Actual targets:"; - let targets = - List.concat_map targets ~f:(function - | Ok targets -> targets - | Error _ -> []) in - List.iter targets ~f:(function - | File path -> - Log.info log @@ "- " ^ (Path.to_string path) - | Alias path -> - Log.info log @@ "- alias " ^ - (Path.to_string_maybe_quoted path) - | Alias_rec path -> - Log.info log @@ "- recursive alias " ^ - (Path.to_string_maybe_quoted path)); - flush stdout; + List.concat_map targets ~f:(function + | Ok targets -> targets + | Error _ -> []) + |> log_targets ~log end; targets +let resolve_targets ~log common (setup : Main.setup) user_targets = + List.map ~f:(fun s -> String s) user_targets + |> resolve_targets_mixed ~log common setup + let resolve_targets_exn ~log common setup user_targets = resolve_targets ~log common setup user_targets |> List.concat_map ~f:(function @@ -1230,8 +1244,8 @@ let exec = [p] | `This_abs _ -> []) - |> List.map ~f:Path.to_string - |> resolve_targets ~log common setup + |> List.map ~f:(fun p -> Path p) + |> resolve_targets_mixed ~log common setup |> List.concat_map ~f:(function | Ok targets -> targets | Error _ -> []) diff --git a/test/blackbox-tests/dune.inc b/test/blackbox-tests/dune.inc index af7c5ab8..7295b221 100644 --- a/test/blackbox-tests/dune.inc +++ b/test/blackbox-tests/dune.inc @@ -103,6 +103,14 @@ test-cases/dev-flag-1103 (progn (run %{exe:cram.exe} -test run.t) (diff? run.t run.t.corrected))))) +(alias + (name dune-build-dir-exec-1101) + (deps (package dune) (source_tree test-cases/dune-build-dir-exec-1101)) + (action + (chdir + test-cases/dune-build-dir-exec-1101 + (progn (run %{exe:cram.exe} -test run.t) (diff? run.t run.t.corrected))))) + (alias (name dune-jbuild-var-case) (deps (package dune) (source_tree test-cases/dune-jbuild-var-case)) @@ -764,6 +772,7 @@ (alias dep-vars) (alias depend-on-the-universe) (alias dev-flag-1103) + (alias dune-build-dir-exec-1101) (alias dune-jbuild-var-case) (alias dune-ppx-driver-system) (alias dune-project-edition) @@ -858,6 +867,7 @@ (alias dep-vars) (alias depend-on-the-universe) (alias dev-flag-1103) + (alias dune-build-dir-exec-1101) (alias dune-jbuild-var-case) (alias dune-ppx-driver-system) (alias dune-project-edition) diff --git a/test/blackbox-tests/test-cases/dune-build-dir-exec-1101/dune b/test/blackbox-tests/test-cases/dune-build-dir-exec-1101/dune new file mode 100644 index 00000000..8ac60cee --- /dev/null +++ b/test/blackbox-tests/test-cases/dune-build-dir-exec-1101/dune @@ -0,0 +1 @@ +(executable (name main)) \ No newline at end of file diff --git a/test/blackbox-tests/test-cases/dune-build-dir-exec-1101/dune-project b/test/blackbox-tests/test-cases/dune-build-dir-exec-1101/dune-project new file mode 100644 index 00000000..6687faf2 --- /dev/null +++ b/test/blackbox-tests/test-cases/dune-build-dir-exec-1101/dune-project @@ -0,0 +1 @@ +(lang dune 1.1) \ No newline at end of file diff --git a/test/blackbox-tests/test-cases/dune-build-dir-exec-1101/main.ml b/test/blackbox-tests/test-cases/dune-build-dir-exec-1101/main.ml new file mode 100644 index 00000000..6bf92d61 --- /dev/null +++ b/test/blackbox-tests/test-cases/dune-build-dir-exec-1101/main.ml @@ -0,0 +1 @@ +print_endline "foobar";; diff --git a/test/blackbox-tests/test-cases/dune-build-dir-exec-1101/run.t b/test/blackbox-tests/test-cases/dune-build-dir-exec-1101/run.t new file mode 100644 index 00000000..4598a1b9 --- /dev/null +++ b/test/blackbox-tests/test-cases/dune-build-dir-exec-1101/run.t @@ -0,0 +1,2 @@ + $ DUNE_BUILD_DIR="$PWD/_custom" dune exec ./main.exe + foobar