Track locations when executing programs
Only works for searched programs for now Signed-off-by: Rudi Grinberg <rudi.grinberg@gmail.com>
This commit is contained in:
parent
4483627348
commit
a064b59692
|
@ -1,6 +1,8 @@
|
||||||
open Import
|
open Import
|
||||||
open Sexp.Of_sexp
|
open Sexp.Of_sexp
|
||||||
|
|
||||||
|
let ignore_loc k ~loc:_ = k
|
||||||
|
|
||||||
module Outputs = struct
|
module Outputs = struct
|
||||||
include Action_intf.Outputs
|
include Action_intf.Outputs
|
||||||
|
|
||||||
|
@ -257,10 +259,11 @@ module Prog = struct
|
||||||
{ context : string
|
{ context : string
|
||||||
; program : string
|
; program : string
|
||||||
; hint : string option
|
; hint : string option
|
||||||
|
; loc : Loc.t option
|
||||||
}
|
}
|
||||||
|
|
||||||
let raise { context ; program ; hint } =
|
let raise { context ; program ; hint ; loc } =
|
||||||
Utils.program_not_found ?hint ~context program
|
Utils.program_not_found ?hint ~loc ~context program
|
||||||
end
|
end
|
||||||
|
|
||||||
type t = (Path.t, Not_found.t) result
|
type t = (Path.t, Not_found.t) result
|
||||||
|
@ -320,13 +323,13 @@ module Unresolved = struct
|
||||||
module Program = struct
|
module Program = struct
|
||||||
type t =
|
type t =
|
||||||
| This of Path.t
|
| This of Path.t
|
||||||
| Search of string
|
| Search of Loc.t option * string
|
||||||
|
|
||||||
let of_string ~dir s =
|
let of_string ~dir ~loc s =
|
||||||
if String.contains s '/' then
|
if String.contains s '/' then
|
||||||
This (Path.relative dir s)
|
This (Path.relative dir s)
|
||||||
else
|
else
|
||||||
Search s
|
Search (loc, s)
|
||||||
end
|
end
|
||||||
|
|
||||||
module type Uast = Action_intf.Ast
|
module type Uast = Action_intf.Ast
|
||||||
|
@ -345,18 +348,20 @@ module Unresolved = struct
|
||||||
~f_string:(fun ~dir:_ x -> x)
|
~f_string:(fun ~dir:_ x -> x)
|
||||||
~f_program:(fun ~dir:_ -> function
|
~f_program:(fun ~dir:_ -> function
|
||||||
| This p -> Ok p
|
| This p -> Ok p
|
||||||
| Search s -> Ok (f s))
|
| Search (loc, s) -> Ok (f loc s))
|
||||||
end
|
end
|
||||||
|
|
||||||
let prog_and_args_of_values p ~dir =
|
let prog_and_args_of_values ~loc p ~dir =
|
||||||
match p with
|
match p with
|
||||||
| [] -> (Unresolved.Program.Search "", [])
|
| [] -> (Unresolved.Program.Search (loc, ""), [])
|
||||||
| Value.Dir p :: _ ->
|
| Value.Dir p :: _ ->
|
||||||
die "%s is a directory and cannot be used as an executable"
|
die "%s is a directory and cannot be used as an executable"
|
||||||
(Path.to_string_maybe_quoted p)
|
(Path.to_string_maybe_quoted p)
|
||||||
| Value.Path p :: xs -> (This p, Value.L.to_strings ~dir xs)
|
| Value.Path p :: xs -> (This p, Value.L.to_strings ~dir xs)
|
||||||
| String s :: xs ->
|
| String s :: xs ->
|
||||||
(Unresolved.Program.of_string ~dir s, Value.L.to_strings ~dir xs)
|
( Unresolved.Program.of_string ~loc ~dir s
|
||||||
|
, Value.L.to_strings ~dir xs
|
||||||
|
)
|
||||||
|
|
||||||
module Unexpanded = struct
|
module Unexpanded = struct
|
||||||
module type Uast = Action_intf.Ast
|
module type Uast = Action_intf.Ast
|
||||||
|
@ -398,17 +403,19 @@ module Unexpanded = struct
|
||||||
module E = struct
|
module E = struct
|
||||||
let expand ~dir ~mode ~f ~l ~r =
|
let expand ~dir ~mode ~f ~l ~r =
|
||||||
Either.map ~l
|
Either.map ~l
|
||||||
~r:(fun s -> r (String_with_vars.expand s ~dir ~f ~mode) ~dir)
|
~r:(fun s ->
|
||||||
|
r ~loc:(Some (String_with_vars.loc s))
|
||||||
|
(String_with_vars.expand s ~dir ~f ~mode) ~dir)
|
||||||
|
|
||||||
let string =
|
let string =
|
||||||
expand ~mode:Single
|
expand ~mode:Single
|
||||||
~l:(fun x -> x)
|
~l:(fun x -> x)
|
||||||
~r:Value.to_string
|
~r:(ignore_loc Value.to_string)
|
||||||
|
|
||||||
let strings =
|
let strings =
|
||||||
expand ~mode:Many
|
expand ~mode:Many
|
||||||
~l:(fun x -> [x])
|
~l:(fun x -> [x])
|
||||||
~r:Value.L.to_strings
|
~r:(ignore_loc Value.L.to_strings)
|
||||||
|
|
||||||
let path e =
|
let path e =
|
||||||
let error_loc =
|
let error_loc =
|
||||||
|
@ -417,7 +424,7 @@ module Unexpanded = struct
|
||||||
| Right r -> Some (String_with_vars.loc r) in
|
| Right r -> Some (String_with_vars.loc r) in
|
||||||
expand ~mode:Single
|
expand ~mode:Single
|
||||||
~l:(fun x -> x)
|
~l:(fun x -> x)
|
||||||
~r:Value.(to_path ?error_loc) e
|
~r:(ignore_loc (Value.(to_path ?error_loc))) e
|
||||||
|
|
||||||
let prog_and_args =
|
let prog_and_args =
|
||||||
expand ~mode:Many
|
expand ~mode:Many
|
||||||
|
@ -488,15 +495,17 @@ module Unexpanded = struct
|
||||||
module E = struct
|
module E = struct
|
||||||
let expand ~dir ~mode ~f ~map x =
|
let expand ~dir ~mode ~f ~map x =
|
||||||
match String_with_vars.partial_expand ~mode ~dir ~f x with
|
match String_with_vars.partial_expand ~mode ~dir ~f x with
|
||||||
| Expanded e -> Left (map e ~dir)
|
| Expanded e ->
|
||||||
|
let loc = Some (String_with_vars.loc x) in
|
||||||
|
Left (map ~loc e ~dir)
|
||||||
| Unexpanded x -> Right x
|
| Unexpanded x -> Right x
|
||||||
|
|
||||||
let string = expand ~mode:Single ~map:Value.to_string
|
let string = expand ~mode:Single ~map:(ignore_loc Value.to_string)
|
||||||
let strings = expand ~mode:Many ~map:Value.L.to_strings
|
let strings = expand ~mode:Many ~map:(ignore_loc Value.L.to_strings)
|
||||||
let cat_strings = expand ~mode:Many ~map:Value.L.concat
|
let cat_strings = expand ~mode:Many ~map:(ignore_loc Value.L.concat)
|
||||||
let path x =
|
let path x =
|
||||||
let error_loc = String_with_vars.loc x in
|
expand ~mode:Single ~map:(fun ~loc v ~dir ->
|
||||||
expand ~mode:Single ~map:(Value.to_path ~error_loc) x
|
Value.to_path ?error_loc:loc v ~dir) x
|
||||||
let prog_and_args = expand ~mode:Many ~map:prog_and_args_of_values
|
let prog_and_args = expand ~mode:Many ~map:prog_and_args_of_values
|
||||||
end
|
end
|
||||||
|
|
||||||
|
|
|
@ -11,6 +11,7 @@ module Prog : sig
|
||||||
{ context : string
|
{ context : string
|
||||||
; program : string
|
; program : string
|
||||||
; hint : string option
|
; hint : string option
|
||||||
|
; loc : Loc.t option
|
||||||
}
|
}
|
||||||
|
|
||||||
val raise : t -> _
|
val raise : t -> _
|
||||||
|
@ -54,7 +55,7 @@ module Unresolved : sig
|
||||||
module Program : sig
|
module Program : sig
|
||||||
type t =
|
type t =
|
||||||
| This of Path.t
|
| This of Path.t
|
||||||
| Search of string
|
| Search of Loc.t option * string
|
||||||
end
|
end
|
||||||
|
|
||||||
include Action_intf.Ast
|
include Action_intf.Ast
|
||||||
|
@ -62,7 +63,7 @@ module Unresolved : sig
|
||||||
with type path := Path.t
|
with type path := Path.t
|
||||||
with type string := string
|
with type string := string
|
||||||
|
|
||||||
val resolve : t -> f:(string -> Path.t) -> action
|
val resolve : t -> f:(Loc.t option -> string -> Path.t) -> action
|
||||||
end with type action := t
|
end with type action := t
|
||||||
|
|
||||||
module Unexpanded : sig
|
module Unexpanded : sig
|
||||||
|
|
|
@ -51,7 +51,7 @@ let create (context : Context.t) ~public_libs l ~f =
|
||||||
; public_libs
|
; public_libs
|
||||||
}
|
}
|
||||||
|
|
||||||
let binary t ?hint name =
|
let binary t ?hint ~loc name =
|
||||||
if not (Filename.is_relative name) then
|
if not (Filename.is_relative name) then
|
||||||
Ok (Path.of_filename_relative_to_initial_cwd name)
|
Ok (Path.of_filename_relative_to_initial_cwd name)
|
||||||
else
|
else
|
||||||
|
@ -66,6 +66,7 @@ let binary t ?hint name =
|
||||||
program = name
|
program = name
|
||||||
; hint
|
; hint
|
||||||
; context = t.context.Context.name
|
; context = t.context.Context.name
|
||||||
|
; loc
|
||||||
}
|
}
|
||||||
|
|
||||||
let file_of_lib t ~loc ~lib ~file =
|
let file_of_lib t ~loc ~lib ~file =
|
||||||
|
|
|
@ -16,6 +16,7 @@ val create
|
||||||
val binary
|
val binary
|
||||||
: t
|
: t
|
||||||
-> ?hint:string
|
-> ?hint:string
|
||||||
|
-> loc:Loc.t option
|
||||||
-> string
|
-> string
|
||||||
-> Action.Prog.t
|
-> Action.Prog.t
|
||||||
|
|
||||||
|
|
|
@ -146,7 +146,7 @@ let create ~(kind : Kind.t) ~path ~env ~env_nodes ~name ~merlin ~targets
|
||||||
Hashtbl.add opam_var_cache "root" root
|
Hashtbl.add opam_var_cache "root" root
|
||||||
| Default -> ());
|
| Default -> ());
|
||||||
let prog_not_found_in_path prog =
|
let prog_not_found_in_path prog =
|
||||||
Utils.program_not_found prog ~context:name
|
Utils.program_not_found prog ~context:name ~loc:None
|
||||||
in
|
in
|
||||||
let which_cache = Hashtbl.create 128 in
|
let which_cache = Hashtbl.create 128 in
|
||||||
let which x = which ~cache:which_cache ~path x in
|
let which x = which ~cache:which_cache ~path x in
|
||||||
|
@ -424,7 +424,7 @@ let default ?(merlin=true) ~env_nodes ~env ~targets () =
|
||||||
let create_for_opam ?root ~env ~env_nodes ~targets ~profile ~switch ~name
|
let create_for_opam ?root ~env ~env_nodes ~targets ~profile ~switch ~name
|
||||||
?(merlin=false) () =
|
?(merlin=false) () =
|
||||||
match Bin.opam with
|
match Bin.opam with
|
||||||
| None -> Utils.program_not_found "opam"
|
| None -> Utils.program_not_found "opam" ~loc:None
|
||||||
| Some fn ->
|
| Some fn ->
|
||||||
(match root with
|
(match root with
|
||||||
| Some root -> Fiber.return root
|
| Some root -> Fiber.return root
|
||||||
|
|
|
@ -133,7 +133,7 @@ module Gen(P : Install_rules.Params) = struct
|
||||||
(* We have to execute the rule in the library directory as
|
(* We have to execute the rule in the library directory as
|
||||||
the .o is produced in the current directory *)
|
the .o is produced in the current directory *)
|
||||||
~dir:(Path.parent_exn src)
|
~dir:(Path.parent_exn src)
|
||||||
(SC.resolve_program sctx ctx.c_compiler)
|
(SC.resolve_program ~loc:None sctx ctx.c_compiler)
|
||||||
([ S [A "-I"; Path ctx.stdlib_dir]
|
([ S [A "-I"; Path ctx.stdlib_dir]
|
||||||
; As (SC.cxx_flags sctx)
|
; As (SC.cxx_flags sctx)
|
||||||
; includes
|
; includes
|
||||||
|
|
|
@ -33,7 +33,8 @@ let runtime_file ~sctx fname =
|
||||||
| Ok f -> Arg_spec.Dep f
|
| Ok f -> Arg_spec.Dep f
|
||||||
|
|
||||||
let js_of_ocaml_rule sctx ~dir ~flags ~spec ~target =
|
let js_of_ocaml_rule sctx ~dir ~flags ~spec ~target =
|
||||||
let jsoo = SC.resolve_program sctx ~hint:install_jsoo_hint "js_of_ocaml" in
|
let jsoo =
|
||||||
|
SC.resolve_program sctx ~loc:None ~hint:install_jsoo_hint "js_of_ocaml" in
|
||||||
let runtime = runtime_file ~sctx "runtime.js" in
|
let runtime = runtime_file ~sctx "runtime.js" in
|
||||||
Build.run ~context:(Super_context.context sctx) ~dir
|
Build.run ~context:(Super_context.context sctx) ~dir
|
||||||
jsoo
|
jsoo
|
||||||
|
@ -98,7 +99,8 @@ let link_rule cc ~runtime ~target =
|
||||||
in
|
in
|
||||||
Arg_spec.Deps (List.concat [all_libs;all_other_modules]))
|
Arg_spec.Deps (List.concat [all_libs;all_other_modules]))
|
||||||
in
|
in
|
||||||
let jsoo_link = SC.resolve_program sctx ~hint:install_jsoo_hint "jsoo_link" in
|
let jsoo_link =
|
||||||
|
SC.resolve_program sctx ~loc:None ~hint:install_jsoo_hint "jsoo_link" in
|
||||||
Build.run ~context:ctx ~dir:(Compilation_context.dir cc)
|
Build.run ~context:ctx ~dir:(Compilation_context.dir cc)
|
||||||
jsoo_link
|
jsoo_link
|
||||||
[ Arg_spec.A "-o"; Target target
|
[ Arg_spec.A "-o"; Target target
|
||||||
|
|
|
@ -71,7 +71,7 @@ module Run (P : PARAMS) = struct
|
||||||
(* Find the menhir binary. *)
|
(* Find the menhir binary. *)
|
||||||
|
|
||||||
let menhir_binary =
|
let menhir_binary =
|
||||||
SC.resolve_program sctx "menhir" ~hint:"opam install menhir"
|
SC.resolve_program sctx "menhir" ~loc:None ~hint:"opam install menhir"
|
||||||
|
|
||||||
(* [menhir args] generates a Menhir command line (a build action). *)
|
(* [menhir args] generates a Menhir command line (a build action). *)
|
||||||
|
|
||||||
|
|
|
@ -83,7 +83,7 @@ module Gen (S : sig val sctx : SC.t end) = struct
|
||||||
let setup_deps m files = SC.add_alias_deps sctx (alias m) files
|
let setup_deps m files = SC.add_alias_deps sctx (alias m) files
|
||||||
end
|
end
|
||||||
|
|
||||||
let odoc = SC.resolve_program sctx "odoc" ~hint:"opam install odoc"
|
let odoc = SC.resolve_program sctx "odoc" ~hint:"opam install odoc" ~loc:None
|
||||||
let odoc_ext = ".odoc"
|
let odoc_ext = ".odoc"
|
||||||
|
|
||||||
module Mld : sig
|
module Mld : sig
|
||||||
|
|
|
@ -415,7 +415,7 @@ let cookie_library_name lib_name =
|
||||||
let setup_reason_rules sctx (m : Module.t) =
|
let setup_reason_rules sctx (m : Module.t) =
|
||||||
let ctx = SC.context sctx in
|
let ctx = SC.context sctx in
|
||||||
let refmt =
|
let refmt =
|
||||||
Artifacts.binary (SC.artifacts sctx) "refmt" ~hint:"opam install reason" in
|
SC.resolve_program sctx ~loc:None "refmt" ~hint:"opam install reason" in
|
||||||
let rule src target =
|
let rule src target =
|
||||||
Build.run ~context:ctx refmt
|
Build.run ~context:ctx refmt
|
||||||
[ A "--print"
|
[ A "--print"
|
||||||
|
|
|
@ -289,7 +289,7 @@ end = struct
|
||||||
| Macro (Dep, s) -> Some (path_exp (Path.relative dir s))
|
| Macro (Dep, s) -> Some (path_exp (Path.relative dir s))
|
||||||
| Macro (Bin, s) -> begin
|
| Macro (Bin, s) -> begin
|
||||||
let sctx = host sctx in
|
let sctx = host sctx in
|
||||||
match Artifacts.binary (artifacts sctx) s with
|
match Artifacts.binary ~loc:None (artifacts sctx) s with
|
||||||
| Ok path -> Some (path_exp path)
|
| Ok path -> Some (path_exp path)
|
||||||
| Error e ->
|
| Error e ->
|
||||||
Resolved_forms.add_fail acc
|
Resolved_forms.add_fail acc
|
||||||
|
@ -482,8 +482,8 @@ let ocaml_flags t ~dir ~scope (x : Buildable.t) =
|
||||||
let dump_env t ~dir =
|
let dump_env t ~dir =
|
||||||
Ocaml_flags.dump (Env.ocaml_flags t ~dir)
|
Ocaml_flags.dump (Env.ocaml_flags t ~dir)
|
||||||
|
|
||||||
let resolve_program t ?hint bin =
|
let resolve_program t ?hint ~loc bin =
|
||||||
Artifacts.binary ?hint t.artifacts bin
|
Artifacts.binary ?hint ~loc t.artifacts bin
|
||||||
|
|
||||||
let create
|
let create
|
||||||
~(context:Context.t)
|
~(context:Context.t)
|
||||||
|
@ -920,9 +920,9 @@ module Action = struct
|
||||||
expand_step2 t ~dir ~dynamic_expansions ~deps_written_by_user ~map_exe
|
expand_step2 t ~dir ~dynamic_expansions ~deps_written_by_user ~map_exe
|
||||||
~bindings
|
~bindings
|
||||||
in
|
in
|
||||||
Action.Unresolved.resolve unresolved ~f:(fun prog ->
|
Action.Unresolved.resolve unresolved ~f:(fun loc prog ->
|
||||||
let sctx = host sctx in
|
let sctx = host sctx in
|
||||||
match Artifacts.binary sctx.artifacts prog with
|
match Artifacts.binary ~loc sctx.artifacts prog with
|
||||||
| Ok path -> path
|
| Ok path -> path
|
||||||
| Error fail -> Action.Prog.Not_found.raise fail))
|
| Error fail -> Action.Prog.Not_found.raise fail))
|
||||||
>>>
|
>>>
|
||||||
|
|
|
@ -170,6 +170,7 @@ val source_files : t -> src_path:Path.t -> String.Set.t
|
||||||
val resolve_program
|
val resolve_program
|
||||||
: t
|
: t
|
||||||
-> ?hint:string
|
-> ?hint:string
|
||||||
|
-> loc:Loc.t option
|
||||||
-> string
|
-> string
|
||||||
-> Action.Prog.t
|
-> Action.Prog.t
|
||||||
|
|
||||||
|
|
|
@ -113,8 +113,9 @@ let library_object_directory ~dir name =
|
||||||
let executable_object_directory ~dir name =
|
let executable_object_directory ~dir name =
|
||||||
Path.relative dir ("." ^ name ^ ".eobjs")
|
Path.relative dir ("." ^ name ^ ".eobjs")
|
||||||
|
|
||||||
let program_not_found ?context ?hint prog =
|
let program_not_found ?context ?hint ~loc prog =
|
||||||
die "@{<error>Error@}: Program %s not found in the tree or in PATH%s%a"
|
Loc.fail_opt loc
|
||||||
|
"@{<error>Error@}: Program %s not found in the tree or in PATH%s%a"
|
||||||
(String.maybe_quoted prog)
|
(String.maybe_quoted prog)
|
||||||
(match context with
|
(match context with
|
||||||
| None -> ""
|
| None -> ""
|
||||||
|
|
|
@ -41,6 +41,7 @@ val analyse_target : Path.t -> target_kind
|
||||||
val program_not_found
|
val program_not_found
|
||||||
: ?context:string
|
: ?context:string
|
||||||
-> ?hint:string
|
-> ?hint:string
|
||||||
|
-> loc:Loc.t option
|
||||||
-> string
|
-> string
|
||||||
-> _
|
-> _
|
||||||
|
|
||||||
|
|
|
@ -230,7 +230,7 @@ let subst_git ?name () =
|
||||||
let git =
|
let git =
|
||||||
match Bin.which "git" with
|
match Bin.which "git" with
|
||||||
| Some x -> x
|
| Some x -> x
|
||||||
| None -> Utils.program_not_found "git"
|
| None -> Utils.program_not_found "git" ~loc:None
|
||||||
in
|
in
|
||||||
let env = Env.initial in
|
let env = Env.initial in
|
||||||
Fiber.fork_and_join
|
Fiber.fork_and_join
|
||||||
|
|
|
@ -9,5 +9,6 @@ Path that needs to be searched:
|
||||||
|
|
||||||
$ dune runtest --root search-path
|
$ dune runtest --root search-path
|
||||||
Entering directory 'search-path'
|
Entering directory 'search-path'
|
||||||
Error: Program foo-does-not-exist not found in the tree or in PATH (context: default)
|
File "dune", line 3, characters 14-32:
|
||||||
|
Error: Error: Program foo-does-not-exist not found in the tree or in PATH (context: default)
|
||||||
[1]
|
[1]
|
||||||
|
|
Loading…
Reference in New Issue