Fix jbuilder rule in case of missing binaries (#292)

Make jbuilder rules work even when binaries are missing

* Proper error messages for missing binaries

* Unify Prog_spec and Maybe_prog

both can simply be unified into a path type that has a hint for the error

* Remove scarcely useful in_the_tree parameter

It's always true except for the C compiler. In which case, there's no harm in
making it true.

* Make Artifacts return Action.Prog

The old return value was simply converted to this anyway. It's simpler to just
return the proper error straight up.

* Remove remains of in_the_tree

src/action.ml

@@ -128,14 +128,35 @@ module Make_mapper
     | Digest_files x -> Digest_files (List.map x ~f:f_path)
 end
 
+module Prog = struct
+  module Not_found = struct
+    type t =
+      { context : string
+      ; program : string
+      ; hint    : string option
+      }
+
+    let raise { context ; program ; hint } =
+      Utils.program_not_found ?hint ~context program
+  end
+
+  type t = (Path.t, Not_found.t) result
+
+  let t sexp = Ok (Path.t sexp)
+
+  let sexp_of_t = function
+    | Ok s -> Path.sexp_of_t s
+    | Error (e : Not_found.t) -> Sexp.To_sexp.string e.program
+end
+
 module type Ast = Action_intf.Ast
-  with type program = Path.t
+  with type program = Prog.t
   with type path    = Path.t
   with type string  = String.t
 module rec Ast : Ast = Ast
 
 include Make_ast
-    (Path)
+    (Prog)
     (Path)
     (struct
       type t = string
@@ -169,8 +190,8 @@ module Unresolved = struct
   let resolve t ~f =
     map t ~f_path:(fun x -> x) ~f_string:(fun x -> x)
       ~f_program:(function
-        | This p -> p
+        | This p -> Ok p
-        | Search s -> f s)
+        | Search s -> Ok (f s))
 end
 
 module Var_expansion = struct
@@ -519,7 +540,9 @@ let exec_echo stdout_to str =
 
 let rec exec t ~ectx ~dir ~env_extra ~stdout_to ~stderr_to =
   match t with
-  | Run (prog, args) ->
+  | Run (Error e, _) ->
+    Prog.Not_found.raise e
+  | Run (Ok prog, args) ->
     run ~ectx ~dir ~env_extra ~stdout_to ~stderr_to prog args
   | Chdir (dir, t) ->
     exec t ~ectx ~dir ~env_extra ~stdout_to ~stderr_to
@@ -657,7 +680,10 @@ let sandbox t ~sandboxed ~deps ~targets =
           Some (Ast.Symlink (path, sandboxed path))
         else
           None))
-    ; map t ~f_string:(fun x -> x) ~f_path:sandboxed ~f_program:sandboxed
+    ; map t ~f_string:(fun x -> x) ~f_path:sandboxed
+        ~f_program:(function
+        | Ok p -> Ok (sandboxed p)
+        | Error _ as e -> e)
     ; Progn (List.filter_map targets ~f:(fun path ->
         if Path.is_local path then
           Some (Ast.Rename (sandboxed path, path))
@@ -680,7 +706,8 @@ module Infer = struct
 
   let rec infer acc t =
     match t with
-    | Run (prog, _)        -> acc +< prog
+    | Run (Ok prog, _)        -> acc +< prog
+    | Run (Error _, _) -> acc
     | Redirect (_, fn, t)  -> infer (acc +@ fn) t
     | Cat fn               -> acc +< fn
     | Write_file (fn, _)  -> acc +@ fn

src/action.mli

@@ -14,8 +14,24 @@ end
 
 module Outputs : module type of struct include Action_intf.Outputs end
 
+(** result of the lookup of a program, the path to it or information about the
+    failure and possibly a hint how to fix it *)
+module Prog : sig
+  module Not_found : sig
+    type t =
+      { context : string
+      ; program : string
+      ; hint    : string option
+      }
+
+    val raise : t -> _
+  end
+
+  type t = (Path.t, Not_found.t) result
+end
+
 include Action_intf.Ast
-  with type program := Path.t
+  with type program := Prog.t
   with type path    := Path.t
   with type string  := string
 

src/artifacts.ml

@@ -57,10 +57,10 @@ let create (context : Context.t) l ~f =
   ; local_libs
   }
 
-let binary t ?hint ?(in_the_tree=true) name =
+let binary t ?hint name =
   if not (Filename.is_relative name) then
     Ok (Path.absolute name)
-  else if in_the_tree then begin
+  else
     match String_map.find name t.local_bins with
     | Some path -> Ok path
     | None ->
@@ -68,24 +68,11 @@ let binary t ?hint ?(in_the_tree=true) name =
       | Some p -> Ok p
       | None ->
         Error
-          { fail = fun () ->
+          { Action.Prog.Not_found.
-              Utils.program_not_found name
+            program = name
-                ~context:t.context.name
+          ; hint
-                ?hint
+          ; context = t.context.Context.name
-                ~in_the_tree:true
           }
-  end else begin
-    match Context.which t.context name with
-    | Some p -> Ok p
-    | None ->
-      Error
-        { fail = fun () ->
-            Utils.program_not_found name
-              ~context:t.context.name
-              ?hint
-              ~in_the_tree:false
-        }
-  end
 
 let file_of_lib t ~from ~lib ~file =
   match String_map.find lib t.local_libs with

src/artifacts.mli

@@ -8,17 +8,15 @@ val create
   -> f:('a -> Jbuild.Stanza.t list)
   -> t
 
-(** A named artifact that is looked up in the PATH if not found in the tree or
+(** A named artifact that is looked up in the PATH if not found in the tree
-    [in_the_tree] is [false].
 
     If the name is an absolute path, it is used as it.
 *)
 val binary
   :  t
   -> ?hint:string
-  -> ?in_the_tree:bool (* default true *)
   -> string
-  -> (Path.t, fail) result
+  -> Action.Prog.t
 
 (** [file_of_lib t ~from name] a named artifact that is looked up in the given library.
 

src/build.ml

@@ -6,12 +6,6 @@ module Vspec = struct
   type 'a t = T : Path.t * 'a Vfile_kind.t -> 'a t
 end
 
-module Prog_spec = struct
-  type 'a t =
-    | Dep of Path.t
-    | Dyn of ('a -> Path.t)
-end
-
 type lib_dep_kind =
   | Optional
   | Required
@@ -194,10 +188,11 @@ let files_recursively_in ~dir ~file_tree =
 
 let store_vfile spec = Store_vfile spec
 
-let get_prog (prog : _ Prog_spec.t) =
+let get_prog = function
-  match prog with
+  | Ok p -> path p >>> arr (fun _ -> Ok p)
-  | Dep p -> path p >>> arr (fun _ -> p)
+  | Error f ->
-  | Dyn f -> arr f >>> dyn_paths (arr (fun x -> [x]))
+    arr (fun _ -> Error f)
+    >>> dyn_paths (arr (function Error _ -> [] | Ok x -> [x]))
 
 let prog_and_args ?(dir=Path.root) prog args =
   Paths (Arg_spec.add_deps args Pset.empty)

src/build.mli

@@ -76,18 +76,12 @@ val fail : ?targets:Path.t list -> fail -> (_, _) t
     result is computed only once. *)
 val memoize : string -> (unit, 'a) t -> (unit, 'a) t
 
-module Prog_spec : sig
-  type 'a t =
-    | Dep of Path.t
-    | Dyn of ('a -> Path.t)
-end
-
 val run
   :  context:Context.t
   -> ?dir:Path.t (* default: [context.build_dir] *)
   -> ?stdout_to:Path.t
   -> ?extra_targets:Path.t list
-  -> 'a Prog_spec.t
+  -> Action.Prog.t
   -> 'a Arg_spec.t list
   -> ('a, Action.t) t
 

src/gen_rules.ml

@@ -108,7 +108,7 @@ module Gen(P : Params) = struct
          >>>
          Build.dyn_paths (Build.arr objs)
          >>>
-         Build.run ~context:ctx (Dep compiler)
+         Build.run ~context:ctx (Ok compiler)
            ~extra_targets:(
              match mode with
              | Byte -> []
@@ -138,7 +138,7 @@ module Gen(P : Params) = struct
          (* We have to execute the rule in the library directory as the .o is produced in
             the current directory *)
          ~dir
-         (Dep ctx.ocamlc)
+         (Ok ctx.ocamlc)
          [ As (Utils.g ())
          ; Dyn (fun (c_flags, libs) ->
              S [ Lib.c_include_flags libs
@@ -163,9 +163,7 @@ module Gen(P : Params) = struct
          (* We have to execute the rule in the library directory as the .o is produced in
             the current directory *)
          ~dir
-         (SC.resolve_program sctx ctx.c_compiler
+         (SC.resolve_program sctx ctx.c_compiler)
-            (* The C compiler surely is not in the tree *)
-            ~in_the_tree:false)
          [ S [A "-I"; Path ctx.stdlib_dir]
          ; As (SC.cxx_flags sctx)
          ; Dyn (fun (cxx_flags, libs) ->
@@ -328,7 +326,7 @@ module Gen(P : Params) = struct
              >>>
              Build.run ~context:ctx
                ~extra_targets:targets
-               (Dep ctx.ocamlmklib)
+               (Ok ctx.ocamlmklib)
                [ As (Utils.g ())
                ; if custom then A "-custom" else As []
                ; A "-o"
@@ -390,7 +388,7 @@ module Gen(P : Params) = struct
           Ocaml_flags.get flags Native
           >>>
           Build.run ~context:ctx
-            (Dep ocamlopt)
+            (Ok ocamlopt)
             [ Dyn (fun flags -> As flags)
             ; A "-shared"; A "-linkall"
             ; A "-I"; Path dir
@@ -473,7 +471,7 @@ module Gen(P : Params) = struct
        (SC.expand_and_eval_set sctx ~scope ~dir link_flags ~standard:[])
        >>>
        Build.run ~context:ctx
-         (Dep compiler)
+         (Ok compiler)
          [ Dyn (fun (_, (flags,_)) -> As flags)
          ; A "-o"; Target exe
          ; Dyn (fun (_, (_, link_flags)) -> As (link_custom @ link_flags))

src/module_compilation.ml

@@ -63,7 +63,7 @@ let build_cm sctx ?sandbox ~dynlink ~flags ~cm_kind ~(dep_graph:Ocamldep.dep_gra
          other_cm_files >>>
          requires &&&
          Ocaml_flags.get_for_cm flags ~cm_kind >>>
-         Build.run ~context:ctx (Dep compiler)
+         Build.run ~context:ctx (Ok compiler)
            ~extra_targets
            [ Dyn (fun (_, ocaml_flags) -> As ocaml_flags)
            ; cmt_args

src/ocamldep.ml

@@ -76,7 +76,7 @@ let rules sctx ~ml_kind ~dir ~item ~modules ~alias_module ~lib_interface_module
   in
   let ctx = SC.context sctx in
   SC.add_rule sctx
-    (Build.run ~context:ctx (Dep ctx.ocamldep) [A "-modules"; S files]
+    (Build.run ~context:ctx (Ok ctx.ocamldep) [A "-modules"; S files]
        ~stdout_to:ocamldep_output);
   Build.memoize (Path.to_string ocamldep_output)
     (Build.lines_of ocamldep_output

src/super_context.ml

@@ -82,13 +82,8 @@ let expand_vars t ~scope ~dir s =
     Some (Path.reach ~from:dir (Path.append t.context.build_dir scope.Scope.root))
   | var -> String_map.find var t.vars)
 
-let resolve_program_internal t ?hint ?(in_the_tree=true) bin =
+let resolve_program t ?hint bin =
-  Artifacts.binary t.artifacts ?hint ~in_the_tree bin
+  Artifacts.binary ?hint t.artifacts bin
-
-let resolve_program t ?hint ?in_the_tree bin =
-  match resolve_program_internal t ?hint ?in_the_tree bin with
-  | Error fail -> Build.Prog_spec.Dyn (fun _ -> fail.fail ())
-  | Ok    path -> Build.Prog_spec.Dep path
 
 let create
       ~(context:Context.t)
@@ -519,7 +514,6 @@ module Action = struct
     in
     let t =
       U.partial_expand dir t ~f:(fun loc key ->
-        let module A = Artifacts in
         let open Action.Var_expansion in
         let cos, var = parse_bang key in
         match String.lsplit2 var ~on:':' with
@@ -527,21 +521,25 @@ module Action = struct
         | Some ("exe"     , s) -> static_dep_exp acc (Path.relative dir s)
         | Some ("path"    , s) -> static_dep_exp acc (Path.relative dir s)
         | Some ("bin"     , s) -> begin
-            match A.binary (artifacts sctx) s with
+            match Artifacts.binary (artifacts sctx) s with
-            | Ok path -> static_dep_exp acc path
+            | Ok path ->
-            | Error fail -> add_fail acc fail
+              static_dep_exp acc path
+            | Error e ->
+              add_fail acc ({ fail = fun () -> Action.Prog.Not_found.raise e })
           end
         (* "findlib" for compatibility with Jane Street packages which are not yet updated
            to convert "findlib" to "lib" *)
         | Some (("lib"|"findlib"), s) -> begin
-            let lib_dep, res = A.file_of_lib (artifacts sctx) ~loc ~from:dir s in
+            let lib_dep, res =
+              Artifacts.file_of_lib (artifacts sctx) ~loc ~from:dir s in
             add_lib_dep acc lib_dep dep_kind;
             match res with
             | Ok path -> static_dep_exp acc path
             | Error fail -> add_fail acc fail
           end
         | Some ("libexec" , s) -> begin
-            let lib_dep, res = A.file_of_lib (artifacts sctx) ~loc ~from:dir s in
+            let lib_dep, res =
+              Artifacts.file_of_lib (artifacts sctx) ~loc ~from:dir s in
             add_lib_dep acc lib_dep dep_kind;
             match res with
             | Error fail -> add_fail acc fail
@@ -693,9 +691,9 @@ module Action = struct
           expand_step2 t ~dir ~dynamic_expansions ~deps_written_by_user
         in
         Action.Unresolved.resolve unresolved ~f:(fun prog ->
-          match resolve_program_internal sctx prog with
+          match Artifacts.binary sctx.artifacts prog with
           | Ok path    -> path
-          | Error fail -> fail.fail ()))
+          | Error fail -> Action.Prog.Not_found.raise fail))
       >>>
       Build.dyn_paths (Build.arr (fun action ->
         let { Action.Infer.Outcome.deps; targets = _ } =
@@ -795,7 +793,7 @@ module PP = struct
        >>>
        Build.dyn_paths (Build.arr (Lib.archive_files ~mode ~ext_lib:ctx.ext_lib))
        >>>
-       Build.run ~context:ctx (Dep compiler)
+       Build.run ~context:ctx (Ok compiler)
          [ A "-o" ; Target target
          ; Dyn (Lib.link_flags ~mode)
          ])
@@ -833,7 +831,8 @@ module PP = struct
      a new module with only OCaml sources *)
   let setup_reason_rules sctx ~dir (m : Module.t) =
     let ctx = sctx.context in
-    let refmt = resolve_program sctx "refmt" ~hint:"opam install reason" in
+    let refmt =
+      Artifacts.binary sctx.artifacts "refmt" ~hint:"opam install reason" in
     let rule src target =
       let src_path = Path.relative dir src in
       Build.run ~context:ctx refmt
@@ -895,7 +894,7 @@ module PP = struct
             (preprocessor_deps
              >>>
              Build.run ~context:sctx.context
-               (Dep ppx_exe)
+               (Ok ppx_exe)
                [ As flags
                ; A "--dump-ast"
                ; As (cookie_library_name lib_name)

src/super_context.mli

@@ -58,19 +58,18 @@ val rules : t -> Build_interpret.Rule.t list
 
 val sources_and_targets_known_so_far : t -> src_path:Path.t -> String_set.t
 
-(** [prog_spec t ?hint ?in_the_tree name] resolve a program. If [in_the_tree] is [true]
+(** [prog_spec t ?hint name] resolve a program. [name] is looked up in the
-    (the default), [name] is looked up in the workspace. Otherwise, or if it is not found
+    workspace, if it is not found in the tree is is looked up in the PATH. If it
-    in the tree is is looked up in the PATH. If it is not found at all, the resulting
+    is not found at all, the resulting [Prog_spec.t] will either return the
-    [Prog_spec.t] will fail when evaluated.
+    resolved path or a record with details about the error and possibly a hint.
 
     [hint] should tell the user what to install when the program is not found.
 *)
 val resolve_program
   :  t
   -> ?hint:string
-  -> ?in_the_tree:bool (* default true *)
   -> string
-  -> _ Build.Prog_spec.t
+  -> Action.Prog.t
 
 module Libs : sig
   val find : t -> from:Path.t -> string -> Lib.t option

src/utils.ml

@@ -88,12 +88,9 @@ let describe_target fn =
   | _ ->
     Path.to_string_maybe_quoted fn
 
-let program_not_found ?context ?(in_the_tree=false) ?hint prog =
+let program_not_found ?context ?hint prog =
-  die "@{<error>Error@}: Program %s not found in%s PATH%s%a" (maybe_quoted prog)
+  die "@{<error>Error@}: Program %s not found in the tree or in PATH%s%a"
-    (if in_the_tree then
+    (maybe_quoted prog)
-       " the tree or in"
-     else
-       "")
     (match context with
      | None -> ""
      | Some name -> sprintf " (context: %s)" name)

src/utils.mli

@@ -18,11 +18,9 @@ val jbuild_name_in : dir:Path.t -> string
 (** Nice description of a target *)
 val describe_target : Path.t -> string
 
-(** Raise an error about a program not found in the PATH. If [in_the_tree] is [true], then
+(** Raise an error about a program not found in the PATH or in the tree *)
-    assume that the program was looked up in the tree as well. *)
 val program_not_found
   :  ?context:string
-  -> ?in_the_tree:bool (* default: false *)
   -> ?hint:string
   -> string
   -> _