From a57c488dd7c3fe5337cfb5aef2df88efd97e9c72 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Tue, 7 Nov 2017 21:42:55 +0800 Subject: [PATCH] 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 | 41 ++++++++++++++++++++++++++++++++------- src/action.mli | 18 ++++++++++++++++- src/artifacts.ml | 25 ++++++------------------ src/artifacts.mli | 6 ++---- src/build.ml | 15 +++++--------- src/build.mli | 8 +------- src/gen_rules.ml | 14 ++++++------- src/module_compilation.ml | 2 +- src/ocamldep.ml | 2 +- src/super_context.ml | 35 ++++++++++++++++----------------- src/super_context.mli | 11 +++++------ src/utils.ml | 9 +++------ src/utils.mli | 4 +--- 13 files changed, 99 insertions(+), 91 deletions(-) diff --git a/src/action.ml b/src/action.ml index c7b8f342..b350a95f 100644 --- a/src/action.ml +++ b/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 - | Search s -> f s) + | This p -> Ok p + | 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 diff --git a/src/action.mli b/src/action.mli index ff5ddf88..a57e0344 100644 --- a/src/action.mli +++ b/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 diff --git a/src/artifacts.ml b/src/artifacts.ml index d774bf04..02df3fd3 100644 --- a/src/artifacts.ml +++ b/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 () -> - Utils.program_not_found name - ~context:t.context.name - ?hint - ~in_the_tree:true + { Action.Prog.Not_found. + program = name + ; hint + ; context = t.context.Context.name } - 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 diff --git a/src/artifacts.mli b/src/artifacts.mli index 5d9861ee..f5447d42 100644 --- a/src/artifacts.mli +++ b/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 - [in_the_tree] is [false]. +(** A named artifact that is looked up in the PATH if not found in the tree 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. diff --git a/src/build.ml b/src/build.ml index 3776b38f..6654f6d3 100644 --- a/src/build.ml +++ b/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) = - match prog with - | Dep p -> path p >>> arr (fun _ -> p) - | Dyn f -> arr f >>> dyn_paths (arr (fun x -> [x])) +let get_prog = function + | Ok p -> path p >>> arr (fun _ -> Ok p) + | Error f -> + 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) diff --git a/src/build.mli b/src/build.mli index 13211195..89d03172 100644 --- a/src/build.mli +++ b/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 diff --git a/src/gen_rules.ml b/src/gen_rules.ml index 2346728f..9bd21cb9 100644 --- a/src/gen_rules.ml +++ b/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 - (* The C compiler surely is not in the tree *) - ~in_the_tree:false) + (SC.resolve_program sctx ctx.c_compiler) [ 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)) diff --git a/src/module_compilation.ml b/src/module_compilation.ml index 2a84891c..153a86ae 100644 --- a/src/module_compilation.ml +++ b/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 diff --git a/src/ocamldep.ml b/src/ocamldep.ml index f1a3d5b5..b9dd920d 100644 --- a/src/ocamldep.ml +++ b/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 diff --git a/src/super_context.ml b/src/super_context.ml index 0c74d8ba..73b7449c 100644 --- a/src/super_context.ml +++ b/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 = - Artifacts.binary t.artifacts ?hint ~in_the_tree 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 resolve_program t ?hint bin = + Artifacts.binary ?hint t.artifacts bin 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 - | Ok path -> static_dep_exp acc path - | Error fail -> add_fail acc fail + match Artifacts.binary (artifacts sctx) s with + | Ok path -> + 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) diff --git a/src/super_context.mli b/src/super_context.mli index 23404c80..33747edd 100644 --- a/src/super_context.mli +++ b/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] - (the default), [name] is looked up in the workspace. Otherwise, or if it is not found - in the tree is is looked up in the PATH. If it is not found at all, the resulting - [Prog_spec.t] will fail when evaluated. +(** [prog_spec t ?hint name] resolve a program. [name] is looked up in the + workspace, if it is not found in the tree is is looked up in the PATH. If it + is not found at all, the resulting [Prog_spec.t] will either return the + 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 diff --git a/src/utils.ml b/src/utils.ml index d0c1ea00..641f7cf5 100644 --- a/src/utils.ml +++ b/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 = - die "@{Error@}: Program %s not found in%s PATH%s%a" (maybe_quoted prog) - (if in_the_tree then - " the tree or in" - else - "") +let program_not_found ?context ?hint prog = + die "@{Error@}: Program %s not found in the tree or in PATH%s%a" + (maybe_quoted prog) (match context with | None -> "" | Some name -> sprintf " (context: %s)" name) diff --git a/src/utils.mli b/src/utils.mli index 28445af8..e3191a3b 100644 --- a/src/utils.mli +++ b/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 - assume that the program was looked up in the tree as well. *) +(** Raise an error about a program not found in the PATH or in the tree *) val program_not_found : ?context:string - -> ?in_the_tree:bool (* default: false *) -> ?hint:string -> string -> _