diff --git a/src/dune/action.ml b/src/dune/action.ml index 93e7ea2d5460..5daeb1a9b10a 100644 --- a/src/dune/action.ml +++ b/src/dune/action.ml @@ -14,16 +14,14 @@ module Prog = struct let create ?hint ~context ~program ~loc () = { hint; context; program; loc } - let user_message { context; program; hint; loc } = + let raise { context; program; hint; loc } = let hint = match program with | "refmt" -> Some (Option.value ~default:"try: opam install reason" hint) | _ -> hint in - Utils.program_not_found_error ?hint ~loc ~context program - - let raise t = raise (User_error.E (user_message t)) + Utils.program_not_found ?hint ~loc ~context program let to_dyn { context; program; hint; loc = _ } = let open Dyn.Encoder in diff --git a/src/dune/action.mli b/src/dune/action.mli index 28770472f6b9..83ca6ab81394 100644 --- a/src/dune/action.mli +++ b/src/dune/action.mli @@ -28,8 +28,6 @@ module Prog : sig -> unit -> t - val user_message : t -> User_message.t - val raise : t -> _ end diff --git a/src/dune/expander.ml b/src/dune/expander.ml index c57f8da99502..e7c28c728100 100644 --- a/src/dune/expander.ml +++ b/src/dune/expander.ml @@ -218,18 +218,12 @@ let expand_str t sw = expand t ~mode:Single ~template:sw |> Value.to_string ~dir:(Path.build t.dir) module Or_exn = struct - (* used to wrap exceptions in [add_fail]. To make sure that we don't - accidentally delay any exceptions that we aren't supposed to *) - exception E of exn - - let raise e = raise (E e) - let expand t ~mode ~template = try Ok (String_with_vars.expand ~dir:(Path.build t.dir) ~mode template ~f:(expand_var_exn t)) - with E e -> Error e + with User_error.E _ as e -> Error e let expand_path t sw = expand t ~mode:Single ~template:sw @@ -343,136 +337,139 @@ let expand_and_record acc ~map_exe ~dep_kind ~expansion_kind ~(dir : Path.Build.t) ~pform t expansion ~(cc : dir:Path.Build.t -> Value.t list Build.t Foreign.Language.Dict.t) = let loc = String_with_vars.Var.loc pform in - let relative d s = Path.build (Path.Build.relative ~error_loc:loc d s) in - let add_ddep = - match expansion_kind with - | Static -> fun _ -> User_error.raise ~loc [ cannot_be_used_here pform ] - | Dynamic -> Resolved_forms.add_ddep acc expansion - in - let add_fail = - match expansion_kind with - | Static -> Or_exn.raise - | Dynamic -> - fun e -> Resolved_forms.add_fail acc { fail = (fun () -> raise e) } - in - let open Build.O in - match (expansion : Pform.Expansion.t) with - | Var - ( Project_root | First_dep | Deps | Targets | Target | Named_local - | Values _ ) - | Macro ((Ocaml_config | Env | Version), _) -> - assert false - | Var Cc -> add_ddep (cc ~dir).c - | Var Cxx -> add_ddep (cc ~dir).cxx - | Macro (Artifact a, s) -> - let data = - Build.dyn_paths - (let+ values = - Build.delayed (fun () -> - match expand_artifact ~dir ~loc t a s with - | Some (Ok v) -> v - | Some (Error msg) -> raise (User_error.E msg) - | None -> User_error.raise ~loc [ cannot_be_used_here pform ]) - in - ( values - , List.filter_map values ~f:(function - | Value.Path p -> Some p - | _ -> None) )) + let expansion () = + let relative d s = Path.build (Path.Build.relative ~error_loc:loc d s) in + let add_ddep = + match expansion_kind with + | Static -> fun _ -> User_error.raise ~loc [ cannot_be_used_here pform ] + | Dynamic -> Resolved_forms.add_ddep acc expansion in - add_ddep data - | Macro (Path_no_dep, s) -> Some [ Value.Dir (relative dir s) ] - | Macro (Exe, s) -> Some (path_exp (map_exe (relative dir s))) - | Macro (Dep, s) -> Some (path_exp (relative dir s)) - | Macro (Bin, s) -> ( - match resolve_binary ~loc:(Some loc) t ~prog:s with - | Error e -> add_fail (User_error.E (Action.Prog.Not_found.user_message e)) - | Ok path -> Some (path_exp path) ) - | Macro (Lib { lib_exec; lib_private }, s) -> ( - let lib, file = parse_lib_file ~loc s in - Resolved_forms.add_lib_dep acc lib dep_kind; - match - if lib_private then - let open Result.O in - let* lib = Lib.DB.resolve (Scope.libs t.scope) (loc, lib) in - let current_project_name = Scope.name t.scope - and referenced_project_name = - Lib.info lib |> Lib_info.status |> Lib_info.Status.project_name - in - if - Option.equal Dune_project.Name.equal (Some current_project_name) - referenced_project_name + let open Build.O in + match (expansion : Pform.Expansion.t) with + | Var + ( Project_root | First_dep | Deps | Targets | Target | Named_local + | Values _ ) + | Macro ((Ocaml_config | Env | Version), _) -> + assert false + | Var Cc -> add_ddep (cc ~dir).c + | Var Cxx -> add_ddep (cc ~dir).cxx + | Macro (Artifact a, s) -> + let data = + Build.dyn_paths + (let+ values = + Build.delayed (fun () -> + match expand_artifact ~dir ~loc t a s with + | Some (Ok v) -> v + | Some (Error msg) -> raise (User_error.E msg) + | None -> User_error.raise ~loc [ cannot_be_used_here pform ]) + in + ( values + , List.filter_map values ~f:(function + | Value.Path p -> Some p + | _ -> None) )) + in + add_ddep data + | Macro (Path_no_dep, s) -> Some [ Value.Dir (relative dir s) ] + | Macro (Exe, s) -> Some (path_exp (map_exe (relative dir s))) + | Macro (Dep, s) -> Some (path_exp (relative dir s)) + | Macro (Bin, s) -> ( + match resolve_binary ~loc:(Some loc) t ~prog:s with + | Error e -> Action.Prog.Not_found.raise e + | Ok path -> Some (path_exp path) ) + | Macro (Lib { lib_exec; lib_private }, s) -> ( + let lib, file = parse_lib_file ~loc s in + Resolved_forms.add_lib_dep acc lib dep_kind; + match + if lib_private then + let open Result.O in + let* lib = Lib.DB.resolve (Scope.libs t.scope) (loc, lib) in + let current_project_name = Scope.name t.scope + and referenced_project_name = + Lib.info lib |> Lib_info.status |> Lib_info.Status.project_name + in + if + Option.equal Dune_project.Name.equal (Some current_project_name) + referenced_project_name + then + Ok (Path.relative (Lib_info.src_dir (Lib.info lib)) file) + else + Error + (User_error.E + (User_error.make ~loc + [ Pp.textf + "The variable \"lib-private\" can only refer to \ + libraries within the same project. The current \ + project's name is %S, but the reference is to %s." + (Dune_project.Name.to_string_hum current_project_name) + ( match referenced_project_name with + | Some name -> + "\"" ^ Dune_project.Name.to_string_hum name ^ "\"" + | None -> "an external library" ) + ])) + else + Artifacts.Public_libs.file_of_lib t.lib_artifacts ~loc ~lib ~file + with + | Ok path -> + (* TODO: The [exec = true] case is currently not handled correctly and + does not match the documentation. *) + if (not lib_exec) || (not Sys.win32) || Filename.extension s = ".exe" then - Ok (Path.relative (Lib_info.src_dir (Lib.info lib)) file) + Some (path_exp path) else - Error - (User_error.E - (User_error.make ~loc - [ Pp.textf - "The variable \"lib-private\" can only refer to \ - libraries within the same project. The current \ - project's name is %S, but the reference is to %s." - (Dune_project.Name.to_string_hum current_project_name) - ( match referenced_project_name with - | Some name -> - "\"" ^ Dune_project.Name.to_string_hum name ^ "\"" - | None -> "an external library" ) - ])) - else - Artifacts.Public_libs.file_of_lib t.lib_artifacts ~loc ~lib ~file - with - | Ok path -> - (* TODO: The [exec = true] case is currently not handled correctly and - does not match the documentation. *) - if (not lib_exec) || (not Sys.win32) || Filename.extension s = ".exe" then - Some (path_exp path) - else - let path_exe = Path.extend_basename path ~suffix:".exe" in - let dep = - Build.if_file_exists path_exe - ~then_: - (let+ () = Build.path path_exe in - path_exp path_exe) - ~else_: - (let+ () = Build.path path in - path_exp path) - in - add_ddep dep - | Error e -> - add_fail - ( match lib_private with - | true -> e - | false -> - if Lib.DB.available (Scope.libs t.scope) lib then - User_error.E - (User_error.make ~loc - [ Pp.textf - "The library %S is not public. The variable \"lib\" \ - expands to the file's installation path which is not \ - defined for private libraries." - (Lib_name.to_string lib) - ]) - else - e ) ) - | Macro (Lib_available, s) -> - let lib = Lib_name.parse_string_exn (loc, s) in - Resolved_forms.add_lib_dep acc lib Optional; - Lib.DB.available (Scope.libs t.scope) lib - |> string_of_bool |> str_exp |> Option.some - | Macro (Read, s) -> - let path = relative dir s in - let data = - let+ s = Build.contents path in - [ Value.String s ] - in - add_ddep data - | Macro (Read_lines, s) -> - let path = relative dir s in - let data = Build.map (Build.lines_of path) ~f:Value.L.strings in - add_ddep data - | Macro (Read_strings, s) -> - let path = relative dir s in - let data = Build.map (Build.strings path) ~f:Value.L.strings in - add_ddep data + let path_exe = Path.extend_basename path ~suffix:".exe" in + let dep = + Build.if_file_exists path_exe + ~then_: + (let+ () = Build.path path_exe in + path_exp path_exe) + ~else_: + (let+ () = Build.path path in + path_exp path) + in + add_ddep dep + | Error e -> + raise + ( match lib_private with + | true -> e + | false -> + if Lib.DB.available (Scope.libs t.scope) lib then + User_error.E + (User_error.make ~loc + [ Pp.textf + "The library %S is not public. The variable \"lib\" \ + expands to the file's installation path which is not \ + defined for private libraries." + (Lib_name.to_string lib) + ]) + else + e ) ) + | Macro (Lib_available, s) -> + let lib = Lib_name.parse_string_exn (loc, s) in + Resolved_forms.add_lib_dep acc lib Optional; + Lib.DB.available (Scope.libs t.scope) lib + |> string_of_bool |> str_exp |> Option.some + | Macro (Read, s) -> + let path = relative dir s in + let data = + let+ s = Build.contents path in + [ Value.String s ] + in + add_ddep data + | Macro (Read_lines, s) -> + let path = relative dir s in + let data = Build.map (Build.lines_of path) ~f:Value.L.strings in + add_ddep data + | Macro (Read_strings, s) -> + let path = relative dir s in + let data = Build.map (Build.strings path) ~f:Value.L.strings in + add_ddep data + in + match expansion_kind with + | Static -> expansion () + | Dynamic -> ( + try expansion () + with User_error.E _ as e -> + Resolved_forms.add_fail acc { fail = (fun () -> raise e) } ) let check_multiplicity ~pform ~declaration ~use = let module Multiplicity = Dune_file.Rule.Targets.Multiplicity in diff --git a/src/dune/utils.ml b/src/dune/utils.ml index 0e558c95ec1c..165d737c598c 100644 --- a/src/dune/utils.ml +++ b/src/dune/utils.ml @@ -28,8 +28,8 @@ let bash_exn = User_error.raise [ Pp.textf "I need bash to %s but I couldn't find it :(" needed_to ] -let not_found_error fmt ?loc ?context ?hint x = - User_error.make ?loc +let not_found fmt ?loc ?context ?hint x = + User_error.raise ?loc ( Pp.textf fmt (String.maybe_quoted x) :: ( match context with @@ -41,15 +41,9 @@ let not_found_error fmt ?loc ?context ?hint x = | None -> [] | Some hint -> [ Pp.text hint ] ) -let not_found fmt ?loc ?context ?hint x = - raise (User_error.E (not_found_error fmt ?loc ?context ?hint x)) - -let program_not_found_error ?context ?hint ~loc prog = - not_found_error "Program %s not found in the tree or in PATH" ?context ?hint - ?loc prog - let program_not_found ?context ?hint ~loc prog = - raise (User_error.E (program_not_found_error ?context ?hint ~loc prog)) + not_found "Program %s not found in the tree or in PATH" ?context ?hint ?loc + prog let library_not_found ?context ?hint lib = not_found "Library %s not found" ?context ?hint lib diff --git a/src/dune/utils.mli b/src/dune/utils.mli index ca85a242bf33..9b73238bd0d9 100644 --- a/src/dune/utils.mli +++ b/src/dune/utils.mli @@ -13,13 +13,6 @@ val bash_exn : needed_to:string -> Path.t val program_not_found : ?context:Context_name.t -> ?hint:string -> loc:Loc.t option -> string -> _ -val program_not_found_error : - ?context:Context_name.t - -> ?hint:string - -> loc:Loc.t option - -> string - -> User_message.t - (** Raise an error about a library not found *) val library_not_found : ?context:Context_name.t -> ?hint:string -> string -> _