Track locations when executing programs

Only works for searched programs for now

Signed-off-by: Rudi Grinberg <rudi.grinberg@gmail.com>

src/action.ml

@@ -1,6 +1,8 @@
 open Import
 open Sexp.Of_sexp
 
+let ignore_loc k ~loc:_ = k
+
 module Outputs = struct
   include Action_intf.Outputs
 
@@ -257,10 +259,11 @@ module Prog = struct
       { context : string
       ; program : string
       ; hint    : string option
+      ; loc     : Loc.t option
       }
 
-    let raise { context ; program ; hint } =
-      Utils.program_not_found ?hint ~context program
+    let raise { context ; program ; hint ; loc } =
+      Utils.program_not_found ?hint ~loc ~context program
   end
 
   type t = (Path.t, Not_found.t) result
@@ -320,13 +323,13 @@ module Unresolved = struct
   module Program = struct
     type 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
         This (Path.relative dir s)
       else
-        Search s
+        Search (loc, s)
   end
 
   module type Uast = Action_intf.Ast
@@ -345,18 +348,20 @@ module Unresolved = struct
       ~f_string:(fun ~dir:_ x -> x)
       ~f_program:(fun ~dir:_ -> function
         | This p -> Ok p
-        | Search s -> Ok (f s))
+        | Search (loc, s) -> Ok (f loc s))
 end
 
-let prog_and_args_of_values p ~dir =
+let prog_and_args_of_values ~loc p ~dir =
   match p with
-  | [] -> (Unresolved.Program.Search "", [])
+  | [] -> (Unresolved.Program.Search (loc, ""), [])
   | Value.Dir p :: _ ->
     die "%s is a directory and cannot be used as an executable"
       (Path.to_string_maybe_quoted p)
   | Value.Path p :: xs -> (This p, Value.L.to_strings ~dir 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 type Uast = Action_intf.Ast
@@ -398,17 +403,19 @@ module Unexpanded = struct
     module E = struct
       let expand ~dir ~mode ~f ~l ~r =
         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 =
         expand ~mode:Single
           ~l:(fun x -> x)
-          ~r:Value.to_string
+          ~r:(ignore_loc Value.to_string)
 
       let strings =
         expand ~mode:Many
           ~l:(fun x -> [x])
-          ~r:Value.L.to_strings
+          ~r:(ignore_loc Value.L.to_strings)
 
       let path e =
         let error_loc =
@@ -417,7 +424,7 @@ module Unexpanded = struct
           | Right r -> Some (String_with_vars.loc r) in
         expand ~mode:Single
           ~l:(fun x -> x)
-          ~r:Value.(to_path ?error_loc) e
+          ~r:(ignore_loc (Value.(to_path ?error_loc))) e
 
       let prog_and_args =
         expand ~mode:Many
@@ -488,15 +495,17 @@ module Unexpanded = struct
   module E = struct
     let expand ~dir ~mode ~f ~map x =
       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
 
-    let string = expand ~mode:Single ~map:Value.to_string
-    let strings = expand ~mode:Many ~map:Value.L.to_strings
-    let cat_strings = expand ~mode:Many ~map:Value.L.concat
+    let string = expand ~mode:Single ~map:(ignore_loc Value.to_string)
+    let strings = expand ~mode:Many ~map:(ignore_loc Value.L.to_strings)
+    let cat_strings = expand ~mode:Many ~map:(ignore_loc Value.L.concat)
     let path x =
-      let error_loc = String_with_vars.loc x in
-      expand ~mode:Single ~map:(Value.to_path ~error_loc) x
+      expand ~mode:Single ~map:(fun ~loc v ~dir ->
+        Value.to_path ?error_loc:loc v ~dir) x
     let prog_and_args = expand ~mode:Many ~map:prog_and_args_of_values
   end
 

src/action.mli

@@ -11,6 +11,7 @@ module Prog : sig
       { context : string
       ; program : string
       ; hint    : string option
+      ; loc     : Loc.t option
       }
 
     val raise : t -> _
@@ -54,7 +55,7 @@ module Unresolved : sig
   module Program : sig
     type t =
       | This   of Path.t
-      | Search of string
+      | Search of Loc.t option * string
   end
 
   include Action_intf.Ast
@@ -62,7 +63,7 @@ module Unresolved : sig
     with type path    := Path.t
     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
 
 module Unexpanded : sig

src/artifacts.ml

@@ -51,7 +51,7 @@ let create (context : Context.t) ~public_libs l ~f =
   ; public_libs
   }
 
-let binary t ?hint name =
+let binary t ?hint ~loc name =
   if not (Filename.is_relative name) then
     Ok (Path.of_filename_relative_to_initial_cwd name)
   else
@@ -66,6 +66,7 @@ let binary t ?hint name =
             program = name
           ; hint
           ; context = t.context.Context.name
+          ; loc
           }
 
 let file_of_lib t ~loc ~lib ~file =

src/artifacts.mli

@@ -16,6 +16,7 @@ val create
 val binary
   :  t
   -> ?hint:string
+  -> loc:Loc.t option
   -> string
   -> Action.Prog.t
 

src/context.ml

@@ -146,7 +146,7 @@ let create ~(kind : Kind.t) ~path ~env ~env_nodes ~name ~merlin ~targets
      Hashtbl.add opam_var_cache "root" root
    | Default -> ());
   let prog_not_found_in_path prog =
-    Utils.program_not_found prog ~context:name
+    Utils.program_not_found prog ~context:name ~loc:None
   in
   let which_cache = Hashtbl.create 128 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
       ?(merlin=false) () =
   match Bin.opam with
-  | None -> Utils.program_not_found "opam"
+  | None -> Utils.program_not_found "opam" ~loc:None
   | Some fn ->
     (match root with
      | Some root -> Fiber.return root

src/gen_rules.ml

@@ -133,7 +133,7 @@ module Gen(P : Install_rules.Params) = struct
          (* We have to execute the rule in the library directory as
             the .o is produced in the current directory *)
          ~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]
           ; As (SC.cxx_flags sctx)
           ; includes

src/js_of_ocaml_rules.ml

@@ -33,7 +33,8 @@ let runtime_file ~sctx fname =
   | Ok f -> Arg_spec.Dep f
 
 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
   Build.run ~context:(Super_context.context sctx) ~dir
     jsoo
@@ -98,7 +99,8 @@ let link_rule cc ~runtime ~target =
       in
       Arg_spec.Deps (List.concat [all_libs;all_other_modules]))
   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)
     jsoo_link
     [ Arg_spec.A "-o"; Target target

src/menhir.ml

@@ -71,7 +71,7 @@ module Run (P : PARAMS) = struct
   (* Find the 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). *)
 

src/odoc.ml

@@ -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
   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"
 
   module Mld : sig

src/preprocessing.ml

@@ -415,7 +415,7 @@ let cookie_library_name lib_name =
 let setup_reason_rules sctx (m : Module.t) =
   let ctx = SC.context sctx in
   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 =
     Build.run ~context:ctx refmt
       [ A "--print"

src/super_context.ml

@@ -289,7 +289,7 @@ end = struct
         | Macro (Dep, s) -> Some (path_exp (Path.relative dir s))
         | Macro (Bin, s) -> begin
             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)
             | Error e ->
               Resolved_forms.add_fail acc
@@ -482,8 +482,8 @@ let ocaml_flags t ~dir ~scope (x : Buildable.t) =
 let dump_env t ~dir =
   Ocaml_flags.dump (Env.ocaml_flags t ~dir)
 
-let resolve_program t ?hint bin =
-  Artifacts.binary ?hint t.artifacts bin
+let resolve_program t ?hint ~loc bin =
+  Artifacts.binary ?hint ~loc t.artifacts bin
 
 let create
       ~(context:Context.t)
@@ -920,9 +920,9 @@ module Action = struct
           expand_step2 t ~dir ~dynamic_expansions ~deps_written_by_user ~map_exe
             ~bindings
         in
-        Action.Unresolved.resolve unresolved ~f:(fun prog ->
+        Action.Unresolved.resolve unresolved ~f:(fun loc prog ->
           let sctx = host sctx in
-          match Artifacts.binary sctx.artifacts prog with
+          match Artifacts.binary ~loc sctx.artifacts prog with
           | Ok path    -> path
           | Error fail -> Action.Prog.Not_found.raise fail))
       >>>

src/super_context.mli

@@ -170,6 +170,7 @@ val source_files : t -> src_path:Path.t -> String.Set.t
 val resolve_program
   :  t
   -> ?hint:string
+  -> loc:Loc.t option
   -> string
   -> Action.Prog.t
 

src/utils.ml

@@ -113,8 +113,9 @@ let library_object_directory ~dir name =
 let executable_object_directory ~dir name =
   Path.relative dir ("." ^ name ^ ".eobjs")
 
-let program_not_found ?context ?hint prog =
-  die "@{<error>Error@}: Program %s not found in the tree or in PATH%s%a"
+let program_not_found ?context ?hint ~loc prog =
+  Loc.fail_opt loc
+    "@{<error>Error@}: Program %s not found in the tree or in PATH%s%a"
     (String.maybe_quoted prog)
     (match context with
      | None -> ""

src/utils.mli

@@ -41,6 +41,7 @@ val analyse_target : Path.t -> target_kind
 val program_not_found
   :  ?context:string
   -> ?hint:string
+  -> loc:Loc.t option
   -> string
   -> _
 

src/watermarks.ml

@@ -230,7 +230,7 @@ let subst_git ?name () =
   let git =
     match Bin.which "git" with
     | Some x -> x
-    | None -> Utils.program_not_found "git"
+    | None -> Utils.program_not_found "git" ~loc:None
   in
   let env = Env.initial in
   Fiber.fork_and_join

test/blackbox-tests/test-cases/missing-loc-run/run.t

@@ -9,5 +9,6 @@ Path that needs to be searched:
 
   $ dune runtest --root 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]