From 24041593dac9dd191bc05f8e9bf00d143303f472 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Mon, 23 Apr 2018 14:04:15 +0700 Subject: [PATCH] Move Code_error to Stdune.Exn This exception is useful outside of jbuilder --- src/action.ml | 2 +- src/build_interpret.ml | 2 +- src/build_system.ml | 4 ++-- src/env.ml | 2 +- src/errors.ml | 3 +-- src/errors.mli | 5 ----- src/jbuild.ml | 2 +- src/lib.ml | 4 ++-- src/ocamldep.ml | 2 +- src/ordered_set_lang.ml | 2 +- src/path.ml | 12 ++++++------ src/report_error.ml | 6 +++--- src/scope.ml | 6 +++--- src/sexp.ml | 6 ------ src/sexp.mli | 2 -- src/stdune/exn.ml | 9 +++++++++ src/stdune/exn.mli | 6 ++++++ src/stdune/jbuild | 2 +- src/syntax.ml | 4 ++-- 19 files changed, 41 insertions(+), 40 deletions(-) diff --git a/src/action.ml b/src/action.ml index ac780e89..85ac8f53 100644 --- a/src/action.ml +++ b/src/action.ml @@ -852,7 +852,7 @@ let rec exec t ~ectx ~dir ~env ~stdout_to ~stderr_to = (match Path.kind path with | External _ -> (* Internally we make sure never to do that, and [Unexpanded.*expand] check that *) - Sexp.code_error + Exn.code_error "(mkdir ...) is not supported for paths outside of the workspace" [ "mkdir", Path.sexp_of_t path ] | Local path -> diff --git a/src/build_interpret.ml b/src/build_interpret.ml index 2ab5c98a..8ae453d2 100644 --- a/src/build_interpret.ml +++ b/src/build_interpret.ml @@ -208,7 +208,7 @@ module Rule = struct if Path.parent path <> dir then match loc with | None -> - Sexp.code_error "rule has targets in different directories" + Exn.code_error "rule has targets in different directories" [ "targets", Sexp.To_sexp.list Path.sexp_of_t (List.map targets ~f:Target.path) ] diff --git a/src/build_system.ml b/src/build_system.ml index 957e6006..995c750a 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -1448,7 +1448,7 @@ let get_collector t ~dir = collector | Failed_to_load -> raise Already_reported | Loaded _ | Forward _ -> - Sexp.code_error + Exn.code_error (if Path.is_in_source_tree dir then "Build_system.get_collector called on source directory" else if dir = Path.build_dir then @@ -1477,7 +1477,7 @@ let prefix_rules t prefix ~f = begin match Build_interpret.targets prefix with | [] -> () | targets -> - Sexp.code_error "Build_system.prefix_rules' prefix contains targets" + Exn.code_error "Build_system.prefix_rules' prefix contains targets" ["targets", Path.Set.sexp_of_t (Build_interpret.Target.paths targets)] end; let prefix = diff --git a/src/env.ml b/src/env.ml index e5510ac7..09cf9cd9 100644 --- a/src/env.ml +++ b/src/env.ml @@ -41,7 +41,7 @@ let of_unix arr = |> List.map ~f:(fun s -> match String.lsplit2 s ~on:'=' with | None -> - Sexp.code_error "Env.of_unix: entry without '=' found in the environ" + Exn.code_error "Env.of_unix: entry without '=' found in the environ" ["var", Sexp.To_sexp.string s] | Some (k, v) -> (k, v)) |> Map.of_list_multi diff --git a/src/errors.ml b/src/errors.ml index 56ed2b7f..453f3543 100644 --- a/src/errors.ml +++ b/src/errors.ml @@ -1,5 +1,4 @@ exception Fatal_error of string -exception Code_error of string exception Already_reported let err_buf = Buffer.create 128 @@ -14,7 +13,7 @@ let kerrf fmt ~f = err_ppf fmt let code_errorf fmt = - kerrf fmt ~f:(fun s -> raise (Code_error s)) + kerrf fmt ~f:(fun s -> Stdune.Exn.code_error s []) let die fmt = kerrf fmt ~f:(fun s -> raise (Fatal_error s)) diff --git a/src/errors.mli b/src/errors.mli index a53ffb43..cb728d76 100644 --- a/src/errors.mli +++ b/src/errors.mli @@ -12,11 +12,6 @@ (** A fatal error, that should be reported to the user in a nice way *) exception Fatal_error of string -(* CR-soon diml: replace the [string] argument by [Usexp.t] *) -(** An programming error in the code of jbuilder, that should be reported upstream. The - error message shouldn't try to be developper friendly rather than user friendly. *) -exception Code_error of string - (* CR-soon diml: we won't need this once we can generate rules dynamically *) (** Raised for errors that have already been reported to the user and shouldn't be reported again. This might happen when trying to build a dependency that has already diff --git a/src/jbuild.ml b/src/jbuild.ml index 5d3bee15..d196bef7 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -596,7 +596,7 @@ module Sub_system_info = struct let () = match Sub_system_name.Table.get all name with | Some _ -> - Sexp.code_error "Sub_system_info.register: already registered" + Exn.code_error "Sub_system_info.register: already registered" [ "name", Sexp.To_sexp.string (Sub_system_name.to_string name) ]; | None -> Sub_system_name.Table.set all ~key:name ~data:(Some (module M : S)); diff --git a/src/lib.ml b/src/lib.ml index ba816b0b..7c0bc0aa 100644 --- a/src/lib.ml +++ b/src/lib.ml @@ -600,7 +600,7 @@ let already_in_table (info : Info.t) name x = List [Sexp.unsafe_atom_of_string "Hidden"; Path.sexp_of_t path; Sexp.atom reason] in - Sexp.code_error + Exn.code_error "Lib_db.DB: resolver returned name that's already in the table" [ "name" , Sexp.atom name ; "returned_lib" , to_sexp (info.src_dir, name) @@ -1061,7 +1061,7 @@ module DB = struct let get_compile_info t ?(allow_overlaps=false) name = match find_even_when_hidden t name with | None -> - Sexp.code_error "Lib.DB.get_compile_info got library that doesn't exist" + Exn.code_error "Lib.DB.get_compile_info got library that doesn't exist" [ "name", Sexp.To_sexp.string name ] | Some lib -> let t = Option.some_if (not allow_overlaps) t in diff --git a/src/ocamldep.ml b/src/ocamldep.ml index b8c16dfa..0ef535cc 100644 --- a/src/ocamldep.ml +++ b/src/ocamldep.ml @@ -13,7 +13,7 @@ module Dep_graph = struct match Module.Name.Map.find t.per_module m.name with | Some x -> x | None -> - Sexp.code_error "Ocamldep.Dep_graph.deps_of" + Exn.code_error "Ocamldep.Dep_graph.deps_of" [ "dir", Path.sexp_of_t t.dir ; "modules", Sexp.To_sexp.(list Module.Name.t) (Module.Name.Map.keys t.per_module) diff --git a/src/ordered_set_lang.ml b/src/ordered_set_lang.ml index 67657ccd..29c2293a 100644 --- a/src/ordered_set_lang.ml +++ b/src/ordered_set_lang.ml @@ -235,7 +235,7 @@ module Unexpanded = struct match String.Map.find files_contents fn with | Some x -> x | None -> - Sexp.code_error + Exn.code_error "Ordered_set_lang.Unexpanded.expand" [ "included-file", Quoted_string fn ; "files", Sexp.To_sexp.(list string) diff --git a/src/path.ml b/src/path.ml index f07ad4c9..38dd7911 100644 --- a/src/path.ml +++ b/src/path.ml @@ -290,7 +290,7 @@ let reach t ~from = match is_local t, is_local from with | false, _ -> t | true, false -> - Sexp.code_error "Path.reach called with invalid combination" + Exn.code_error "Path.reach called with invalid combination" [ "t" , sexp_of_t t ; "from", sexp_of_t from ] @@ -300,7 +300,7 @@ let reach_for_running t ~from = match is_local t, is_local from with | false, _ -> t | true, false -> - Sexp.code_error "Path.reach_for_running called with invalid combination" + Exn.code_error "Path.reach_for_running called with invalid combination" [ "t" , sexp_of_t t ; "from", sexp_of_t from ] @@ -325,7 +325,7 @@ let is_descendant t ~of_ = let append a b = if not (is_local b) then - Sexp.code_error "Path.append called with non-local second path" + Exn.code_error "Path.append called with non-local second path" [ "a", sexp_of_t a ; "b", sexp_of_t b ]; @@ -391,7 +391,7 @@ let drop_build_context t = let drop_build_context_exn t = match extract_build_context t with - | None -> Sexp.code_error "Path.drop_build_context_exn" [ "t", sexp_of_t t ] + | None -> Exn.code_error "Path.drop_build_context_exn" [ "t", sexp_of_t t ] | Some (_, t) -> t let drop_optional_build_context t = @@ -424,7 +424,7 @@ let explode_exn t = else if is_local t then String.split t ~on:'/' else - Sexp.code_error "Path.explode_exn" + Exn.code_error "Path.explode_exn" ["path", Sexp.atom_or_quoted_string t] let exists t = Sys.file_exists (to_string t) @@ -456,7 +456,7 @@ let extend_basename t ~suffix = t ^ suffix let insert_after_build_dir_exn = let error a b = - Sexp.code_error + Exn.code_error "Path.insert_after_build_dir_exn" [ "path" , Sexp.unsafe_atom_of_string a ; "insert", Sexp.unsafe_atom_of_string b diff --git a/src/report_error.ml b/src/report_error.ml index ca111d1e..dfc801d9 100644 --- a/src/report_error.ml +++ b/src/report_error.ml @@ -49,14 +49,14 @@ let report_with_backtrace exn = else Format.fprintf ppf "%s\n" (String.capitalize msg) } - | Code_error msg -> + | Stdune.Exn.Code_error sexp -> { p with backtrace = true ; pp = fun ppf -> Format.fprintf ppf "@{Internal error, please report upstream \ including the contents of _build/log.@}\n\ - Description: %s\n" - msg + Description: %a\n" + Usexp.pp sexp } | Unix.Unix_error (err, func, fname) -> { p with pp = fun ppf -> diff --git a/src/scope.ml b/src/scope.ml index c539d109..7abdc431 100644 --- a/src/scope.ml +++ b/src/scope.ml @@ -27,7 +27,7 @@ module DB = struct | Some scope -> scope | None -> if Path.is_root d || not (Path.is_local d) then - Sexp.code_error "Scope.DB.find_by_dir got an invalid path" + Exn.code_error "Scope.DB.find_by_dir got an invalid path" [ "dir" , Path.sexp_of_t dir ; "context", Sexp.To_sexp.string t.context ]; @@ -41,7 +41,7 @@ module DB = struct match Scope_name_map.find t.by_name name with | Some x -> x | None -> - Sexp.code_error "Scope.DB.find_by_name" + Exn.code_error "Scope.DB.find_by_name" [ "name" , Sexp.To_sexp.(option string) name ; "context", Sexp.To_sexp.string t.context ; "names", @@ -60,7 +60,7 @@ module DB = struct Sexp.To_sexp.(pair (option string) Path.sexp_of_t) (scope.name, scope.root) in - Sexp.code_error "Scope.DB.create got two scopes with the same name" + Exn.code_error "Scope.DB.create got two scopes with the same name" [ "scope1", to_sexp scope1 ; "scope2", to_sexp scope2 ] diff --git a/src/sexp.ml b/src/sexp.ml index f89d938c..fca46913 100644 --- a/src/sexp.ml +++ b/src/sexp.ml @@ -3,12 +3,6 @@ open Import include (Usexp : module type of struct include Usexp end with module Loc := Usexp.Loc) -let code_error message vars = - code_errorf "%a" pp - (List (Usexp.atom_or_quoted_string message - :: List.map vars ~f:(fun (name, value) -> - List [Usexp.atom_or_quoted_string name; value]))) - let buf_len = 65_536 let load ~fname ~mode = diff --git a/src/sexp.mli b/src/sexp.mli index 24b48481..7bdeb939 100644 --- a/src/sexp.mli +++ b/src/sexp.mli @@ -2,8 +2,6 @@ open Import include module type of struct include Usexp end with module Loc := Usexp.Loc -val code_error : string -> (string * t) list -> _ - val load : fname:string -> mode:'a Parser.Mode.t -> 'a val load_many_as_one : fname:string -> Ast.t diff --git a/src/stdune/exn.ml b/src/stdune/exn.ml index 469de331..7520ed44 100644 --- a/src/stdune/exn.ml +++ b/src/stdune/exn.ml @@ -1,5 +1,7 @@ type t = exn +exception Code_error of Usexp.t + external raise : exn -> _ = "%raise" external raise_notrace : exn -> _ = "%raise_notrace" external reraise : exn -> _ = "%reraise" @@ -11,6 +13,13 @@ let protectx x ~f ~finally = let protect ~f ~finally = protectx () ~f ~finally +let code_error message vars = + Code_error + (Usexp.List (Usexp.atom_or_quoted_string message + :: List.map vars ~f:(fun (name, value) -> + Usexp.List [Usexp.atom_or_quoted_string name; value]))) + |> raise + include ((struct [@@@warning "-32-3"] diff --git a/src/stdune/exn.mli b/src/stdune/exn.mli index 6df3fa9f..aba7218a 100644 --- a/src/stdune/exn.mli +++ b/src/stdune/exn.mli @@ -1,5 +1,11 @@ (** Exceptions *) +(** An programming error, that should be reported upstream. The error message + shouldn't try to be developer friendly rather than user friendly. *) +exception Code_error of Usexp.t + +val code_error : string -> (string * Usexp.t) list -> _ + type t = exn external raise : exn -> _ = "%raise" diff --git a/src/stdune/jbuild b/src/stdune/jbuild index b1f82de0..f79d508b 100644 --- a/src/stdune/jbuild +++ b/src/stdune/jbuild @@ -2,4 +2,4 @@ ((name stdune) (public_name jbuilder.stdune) (synopsis "[Internal] Standard library of Dune") - (libraries (caml unix)))) + (libraries (caml unix usexp)))) diff --git a/src/syntax.ml b/src/syntax.ml index dc2e1dde..1141fd5f 100644 --- a/src/syntax.ml +++ b/src/syntax.ml @@ -26,14 +26,14 @@ module Versioned_parser = struct let make l = if List.is_empty l then - Sexp.code_error "Syntax.Versioned_parser.make got empty list" []; + Exn.code_error "Syntax.Versioned_parser.make got empty list" []; match List.map l ~f:(fun ((major, minor), p) -> (major, (minor, p))) |> Int_map.of_list with | Ok x -> x | Error _ -> - Sexp.code_error + Exn.code_error "Syntax.Versioned_parser.make" [ "versions", Sexp.To_sexp.list Version.sexp_of_t (List.map l ~f:fst) ]