Move Code_error to Stdune.Exn
This exception is useful outside of jbuilder
This commit is contained in:
parent
98b2ea795c
commit
24041593da
|
@ -852,7 +852,7 @@ let rec exec t ~ectx ~dir ~env ~stdout_to ~stderr_to =
|
||||||
(match Path.kind path with
|
(match Path.kind path with
|
||||||
| External _ ->
|
| External _ ->
|
||||||
(* Internally we make sure never to do that, and [Unexpanded.*expand] check that *)
|
(* 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 ...) is not supported for paths outside of the workspace"
|
||||||
[ "mkdir", Path.sexp_of_t path ]
|
[ "mkdir", Path.sexp_of_t path ]
|
||||||
| Local path ->
|
| Local path ->
|
||||||
|
|
|
@ -208,7 +208,7 @@ module Rule = struct
|
||||||
if Path.parent path <> dir then
|
if Path.parent path <> dir then
|
||||||
match loc with
|
match loc with
|
||||||
| None ->
|
| 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
|
[ "targets", Sexp.To_sexp.list Path.sexp_of_t
|
||||||
(List.map targets ~f:Target.path)
|
(List.map targets ~f:Target.path)
|
||||||
]
|
]
|
||||||
|
|
|
@ -1448,7 +1448,7 @@ let get_collector t ~dir =
|
||||||
collector
|
collector
|
||||||
| Failed_to_load -> raise Already_reported
|
| Failed_to_load -> raise Already_reported
|
||||||
| Loaded _ | Forward _ ->
|
| Loaded _ | Forward _ ->
|
||||||
Sexp.code_error
|
Exn.code_error
|
||||||
(if Path.is_in_source_tree dir then
|
(if Path.is_in_source_tree dir then
|
||||||
"Build_system.get_collector called on source directory"
|
"Build_system.get_collector called on source directory"
|
||||||
else if dir = Path.build_dir then
|
else if dir = Path.build_dir then
|
||||||
|
@ -1477,7 +1477,7 @@ let prefix_rules t prefix ~f =
|
||||||
begin match Build_interpret.targets prefix with
|
begin match Build_interpret.targets prefix with
|
||||||
| [] -> ()
|
| [] -> ()
|
||||||
| targets ->
|
| 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)]
|
["targets", Path.Set.sexp_of_t (Build_interpret.Target.paths targets)]
|
||||||
end;
|
end;
|
||||||
let prefix =
|
let prefix =
|
||||||
|
|
|
@ -41,7 +41,7 @@ let of_unix arr =
|
||||||
|> List.map ~f:(fun s ->
|
|> List.map ~f:(fun s ->
|
||||||
match String.lsplit2 s ~on:'=' with
|
match String.lsplit2 s ~on:'=' with
|
||||||
| None ->
|
| 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]
|
["var", Sexp.To_sexp.string s]
|
||||||
| Some (k, v) -> (k, v))
|
| Some (k, v) -> (k, v))
|
||||||
|> Map.of_list_multi
|
|> Map.of_list_multi
|
||||||
|
|
|
@ -1,5 +1,4 @@
|
||||||
exception Fatal_error of string
|
exception Fatal_error of string
|
||||||
exception Code_error of string
|
|
||||||
exception Already_reported
|
exception Already_reported
|
||||||
|
|
||||||
let err_buf = Buffer.create 128
|
let err_buf = Buffer.create 128
|
||||||
|
@ -14,7 +13,7 @@ let kerrf fmt ~f =
|
||||||
err_ppf fmt
|
err_ppf fmt
|
||||||
|
|
||||||
let code_errorf 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 =
|
let die fmt =
|
||||||
kerrf fmt ~f:(fun s -> raise (Fatal_error s))
|
kerrf fmt ~f:(fun s -> raise (Fatal_error s))
|
||||||
|
|
|
@ -12,11 +12,6 @@
|
||||||
(** A fatal error, that should be reported to the user in a nice way *)
|
(** A fatal error, that should be reported to the user in a nice way *)
|
||||||
exception Fatal_error of string
|
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 *)
|
(* 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
|
(** 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
|
reported again. This might happen when trying to build a dependency that has already
|
||||||
|
|
|
@ -596,7 +596,7 @@ module Sub_system_info = struct
|
||||||
let () =
|
let () =
|
||||||
match Sub_system_name.Table.get all name with
|
match Sub_system_name.Table.get all name with
|
||||||
| Some _ ->
|
| 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) ];
|
[ "name", Sexp.To_sexp.string (Sub_system_name.to_string name) ];
|
||||||
| None ->
|
| None ->
|
||||||
Sub_system_name.Table.set all ~key:name ~data:(Some (module M : S));
|
Sub_system_name.Table.set all ~key:name ~data:(Some (module M : S));
|
||||||
|
|
|
@ -600,7 +600,7 @@ let already_in_table (info : Info.t) name x =
|
||||||
List [Sexp.unsafe_atom_of_string "Hidden";
|
List [Sexp.unsafe_atom_of_string "Hidden";
|
||||||
Path.sexp_of_t path; Sexp.atom reason]
|
Path.sexp_of_t path; Sexp.atom reason]
|
||||||
in
|
in
|
||||||
Sexp.code_error
|
Exn.code_error
|
||||||
"Lib_db.DB: resolver returned name that's already in the table"
|
"Lib_db.DB: resolver returned name that's already in the table"
|
||||||
[ "name" , Sexp.atom name
|
[ "name" , Sexp.atom name
|
||||||
; "returned_lib" , to_sexp (info.src_dir, 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 =
|
let get_compile_info t ?(allow_overlaps=false) name =
|
||||||
match find_even_when_hidden t name with
|
match find_even_when_hidden t name with
|
||||||
| None ->
|
| 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 ]
|
[ "name", Sexp.To_sexp.string name ]
|
||||||
| Some lib ->
|
| Some lib ->
|
||||||
let t = Option.some_if (not allow_overlaps) t in
|
let t = Option.some_if (not allow_overlaps) t in
|
||||||
|
|
|
@ -13,7 +13,7 @@ module Dep_graph = struct
|
||||||
match Module.Name.Map.find t.per_module m.name with
|
match Module.Name.Map.find t.per_module m.name with
|
||||||
| Some x -> x
|
| Some x -> x
|
||||||
| None ->
|
| None ->
|
||||||
Sexp.code_error "Ocamldep.Dep_graph.deps_of"
|
Exn.code_error "Ocamldep.Dep_graph.deps_of"
|
||||||
[ "dir", Path.sexp_of_t t.dir
|
[ "dir", Path.sexp_of_t t.dir
|
||||||
; "modules", Sexp.To_sexp.(list Module.Name.t)
|
; "modules", Sexp.To_sexp.(list Module.Name.t)
|
||||||
(Module.Name.Map.keys t.per_module)
|
(Module.Name.Map.keys t.per_module)
|
||||||
|
|
|
@ -235,7 +235,7 @@ module Unexpanded = struct
|
||||||
match String.Map.find files_contents fn with
|
match String.Map.find files_contents fn with
|
||||||
| Some x -> x
|
| Some x -> x
|
||||||
| None ->
|
| None ->
|
||||||
Sexp.code_error
|
Exn.code_error
|
||||||
"Ordered_set_lang.Unexpanded.expand"
|
"Ordered_set_lang.Unexpanded.expand"
|
||||||
[ "included-file", Quoted_string fn
|
[ "included-file", Quoted_string fn
|
||||||
; "files", Sexp.To_sexp.(list string)
|
; "files", Sexp.To_sexp.(list string)
|
||||||
|
|
12
src/path.ml
12
src/path.ml
|
@ -290,7 +290,7 @@ let reach t ~from =
|
||||||
match is_local t, is_local from with
|
match is_local t, is_local from with
|
||||||
| false, _ -> t
|
| false, _ -> t
|
||||||
| true, false ->
|
| 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
|
[ "t" , sexp_of_t t
|
||||||
; "from", sexp_of_t from
|
; "from", sexp_of_t from
|
||||||
]
|
]
|
||||||
|
@ -300,7 +300,7 @@ let reach_for_running t ~from =
|
||||||
match is_local t, is_local from with
|
match is_local t, is_local from with
|
||||||
| false, _ -> t
|
| false, _ -> t
|
||||||
| true, false ->
|
| 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
|
[ "t" , sexp_of_t t
|
||||||
; "from", sexp_of_t from
|
; "from", sexp_of_t from
|
||||||
]
|
]
|
||||||
|
@ -325,7 +325,7 @@ let is_descendant t ~of_ =
|
||||||
|
|
||||||
let append a b =
|
let append a b =
|
||||||
if not (is_local b) then
|
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
|
[ "a", sexp_of_t a
|
||||||
; "b", sexp_of_t b
|
; "b", sexp_of_t b
|
||||||
];
|
];
|
||||||
|
@ -391,7 +391,7 @@ let drop_build_context t =
|
||||||
|
|
||||||
let drop_build_context_exn t =
|
let drop_build_context_exn t =
|
||||||
match extract_build_context t with
|
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
|
| Some (_, t) -> t
|
||||||
|
|
||||||
let drop_optional_build_context t =
|
let drop_optional_build_context t =
|
||||||
|
@ -424,7 +424,7 @@ let explode_exn t =
|
||||||
else if is_local t then
|
else if is_local t then
|
||||||
String.split t ~on:'/'
|
String.split t ~on:'/'
|
||||||
else
|
else
|
||||||
Sexp.code_error "Path.explode_exn"
|
Exn.code_error "Path.explode_exn"
|
||||||
["path", Sexp.atom_or_quoted_string t]
|
["path", Sexp.atom_or_quoted_string t]
|
||||||
|
|
||||||
let exists t = Sys.file_exists (to_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 insert_after_build_dir_exn =
|
||||||
let error a b =
|
let error a b =
|
||||||
Sexp.code_error
|
Exn.code_error
|
||||||
"Path.insert_after_build_dir_exn"
|
"Path.insert_after_build_dir_exn"
|
||||||
[ "path" , Sexp.unsafe_atom_of_string a
|
[ "path" , Sexp.unsafe_atom_of_string a
|
||||||
; "insert", Sexp.unsafe_atom_of_string b
|
; "insert", Sexp.unsafe_atom_of_string b
|
||||||
|
|
|
@ -49,14 +49,14 @@ let report_with_backtrace exn =
|
||||||
else
|
else
|
||||||
Format.fprintf ppf "%s\n" (String.capitalize msg)
|
Format.fprintf ppf "%s\n" (String.capitalize msg)
|
||||||
}
|
}
|
||||||
| Code_error msg ->
|
| Stdune.Exn.Code_error sexp ->
|
||||||
{ p with
|
{ p with
|
||||||
backtrace = true
|
backtrace = true
|
||||||
; pp = fun ppf ->
|
; pp = fun ppf ->
|
||||||
Format.fprintf ppf "@{<error>Internal error, please report upstream \
|
Format.fprintf ppf "@{<error>Internal error, please report upstream \
|
||||||
including the contents of _build/log.@}\n\
|
including the contents of _build/log.@}\n\
|
||||||
Description: %s\n"
|
Description: %a\n"
|
||||||
msg
|
Usexp.pp sexp
|
||||||
}
|
}
|
||||||
| Unix.Unix_error (err, func, fname) ->
|
| Unix.Unix_error (err, func, fname) ->
|
||||||
{ p with pp = fun ppf ->
|
{ p with pp = fun ppf ->
|
||||||
|
|
|
@ -27,7 +27,7 @@ module DB = struct
|
||||||
| Some scope -> scope
|
| Some scope -> scope
|
||||||
| None ->
|
| None ->
|
||||||
if Path.is_root d || not (Path.is_local d) then
|
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
|
[ "dir" , Path.sexp_of_t dir
|
||||||
; "context", Sexp.To_sexp.string t.context
|
; "context", Sexp.To_sexp.string t.context
|
||||||
];
|
];
|
||||||
|
@ -41,7 +41,7 @@ module DB = struct
|
||||||
match Scope_name_map.find t.by_name name with
|
match Scope_name_map.find t.by_name name with
|
||||||
| Some x -> x
|
| Some x -> x
|
||||||
| None ->
|
| None ->
|
||||||
Sexp.code_error "Scope.DB.find_by_name"
|
Exn.code_error "Scope.DB.find_by_name"
|
||||||
[ "name" , Sexp.To_sexp.(option string) name
|
[ "name" , Sexp.To_sexp.(option string) name
|
||||||
; "context", Sexp.To_sexp.string t.context
|
; "context", Sexp.To_sexp.string t.context
|
||||||
; "names",
|
; "names",
|
||||||
|
@ -60,7 +60,7 @@ module DB = struct
|
||||||
Sexp.To_sexp.(pair (option string) Path.sexp_of_t)
|
Sexp.To_sexp.(pair (option string) Path.sexp_of_t)
|
||||||
(scope.name, scope.root)
|
(scope.name, scope.root)
|
||||||
in
|
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
|
[ "scope1", to_sexp scope1
|
||||||
; "scope2", to_sexp scope2
|
; "scope2", to_sexp scope2
|
||||||
]
|
]
|
||||||
|
|
|
@ -3,12 +3,6 @@ open Import
|
||||||
include (Usexp : module type of struct include Usexp end
|
include (Usexp : module type of struct include Usexp end
|
||||||
with module Loc := Usexp.Loc)
|
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 buf_len = 65_536
|
||||||
|
|
||||||
let load ~fname ~mode =
|
let load ~fname ~mode =
|
||||||
|
|
|
@ -2,8 +2,6 @@ open Import
|
||||||
|
|
||||||
include module type of struct include Usexp end with module Loc := Usexp.Loc
|
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 : fname:string -> mode:'a Parser.Mode.t -> 'a
|
||||||
val load_many_as_one : fname:string -> Ast.t
|
val load_many_as_one : fname:string -> Ast.t
|
||||||
|
|
||||||
|
|
|
@ -1,5 +1,7 @@
|
||||||
type t = exn
|
type t = exn
|
||||||
|
|
||||||
|
exception Code_error of Usexp.t
|
||||||
|
|
||||||
external raise : exn -> _ = "%raise"
|
external raise : exn -> _ = "%raise"
|
||||||
external raise_notrace : exn -> _ = "%raise_notrace"
|
external raise_notrace : exn -> _ = "%raise_notrace"
|
||||||
external reraise : exn -> _ = "%reraise"
|
external reraise : exn -> _ = "%reraise"
|
||||||
|
@ -11,6 +13,13 @@ let protectx x ~f ~finally =
|
||||||
|
|
||||||
let protect ~f ~finally = protectx () ~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
|
include
|
||||||
((struct
|
((struct
|
||||||
[@@@warning "-32-3"]
|
[@@@warning "-32-3"]
|
||||||
|
|
|
@ -1,5 +1,11 @@
|
||||||
(** Exceptions *)
|
(** 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
|
type t = exn
|
||||||
|
|
||||||
external raise : exn -> _ = "%raise"
|
external raise : exn -> _ = "%raise"
|
||||||
|
|
|
@ -2,4 +2,4 @@
|
||||||
((name stdune)
|
((name stdune)
|
||||||
(public_name jbuilder.stdune)
|
(public_name jbuilder.stdune)
|
||||||
(synopsis "[Internal] Standard library of Dune")
|
(synopsis "[Internal] Standard library of Dune")
|
||||||
(libraries (caml unix))))
|
(libraries (caml unix usexp))))
|
||||||
|
|
|
@ -26,14 +26,14 @@ module Versioned_parser = struct
|
||||||
|
|
||||||
let make l =
|
let make l =
|
||||||
if List.is_empty l then
|
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
|
match
|
||||||
List.map l ~f:(fun ((major, minor), p) -> (major, (minor, p)))
|
List.map l ~f:(fun ((major, minor), p) -> (major, (minor, p)))
|
||||||
|> Int_map.of_list
|
|> Int_map.of_list
|
||||||
with
|
with
|
||||||
| Ok x -> x
|
| Ok x -> x
|
||||||
| Error _ ->
|
| Error _ ->
|
||||||
Sexp.code_error
|
Exn.code_error
|
||||||
"Syntax.Versioned_parser.make"
|
"Syntax.Versioned_parser.make"
|
||||||
[ "versions", Sexp.To_sexp.list Version.sexp_of_t (List.map l ~f:fst) ]
|
[ "versions", Sexp.To_sexp.list Version.sexp_of_t (List.map l ~f:fst) ]
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue