Reduce the number of of_sexp_error... functions
Signed-off-by: Jeremie Dimino <jeremie@dimino.org>
This commit is contained in:
parent
30d20d6143
commit
14e6b1e038
|
@ -329,7 +329,7 @@ module Unexpanded = struct
|
|||
let open Sexp.Of_sexp in
|
||||
peek raw >>= function
|
||||
| Atom _ | Quoted_string _ as sexp ->
|
||||
of_sexp_errorf sexp
|
||||
of_sexp_errorf (Sexp.Ast.loc sexp)
|
||||
"if you meant for this to be executed with bash, write (bash \"...\") instead"
|
||||
| List _ -> t
|
||||
|
||||
|
@ -593,7 +593,8 @@ module Promotion = struct
|
|||
Path.t >>= fun dst ->
|
||||
return { src; dst })
|
||||
| sexp ->
|
||||
Sexp.Of_sexp.of_sexp_errorf sexp "(<file> as <file>) expected"
|
||||
Sexp.Of_sexp.of_sexp_errorf (Sexp.Ast.loc sexp)
|
||||
"(<file> as <file>) expected"
|
||||
|
||||
let sexp_of_t { src; dst } =
|
||||
Sexp.List [Path.sexp_of_t src; Sexp.unsafe_atom_of_string "as";
|
||||
|
|
|
@ -65,7 +65,7 @@ module Concurrency = struct
|
|||
let t =
|
||||
plain_string (fun ~loc s ->
|
||||
match of_string s with
|
||||
| Error m -> of_sexp_errorf_loc loc "%s" m
|
||||
| Error m -> of_sexp_errorf loc "%s" m
|
||||
| Ok s -> s)
|
||||
|
||||
let to_string = function
|
||||
|
|
|
@ -75,7 +75,7 @@ end = struct
|
|||
if validate s then
|
||||
Named s
|
||||
else
|
||||
Sexp.Of_sexp.of_sexp_errorf_loc loc "invalid project name")
|
||||
Sexp.Of_sexp.of_sexp_errorf loc "invalid project name")
|
||||
|
||||
let encode = function
|
||||
| Named s -> s
|
||||
|
|
|
@ -47,7 +47,7 @@ module Dune_file = struct
|
|||
| "" | "." | ".." -> true
|
||||
| _ -> false
|
||||
then
|
||||
of_sexp_errorf_loc loc "Invalid sub-directory name %S" dn
|
||||
of_sexp_errorf loc "Invalid sub-directory name %S" dn
|
||||
else
|
||||
dn)
|
||||
in
|
||||
|
|
|
@ -32,7 +32,7 @@ let of_sexp =
|
|||
plain_string (fun ~loc -> function
|
||||
| "1" -> ()
|
||||
| _ ->
|
||||
of_sexp_errorf_loc loc
|
||||
of_sexp_errorf loc
|
||||
"Unsupported version, only version 1 is supported")
|
||||
in
|
||||
sum
|
||||
|
|
|
@ -21,7 +21,7 @@ module Jbuild_version = struct
|
|||
end
|
||||
|
||||
let invalid_module_name ~loc =
|
||||
of_sexp_errorf_loc loc "invalid module name: %S"
|
||||
of_sexp_errorf loc "invalid module name: %S"
|
||||
|
||||
let module_name =
|
||||
plain_string (fun ~loc name ->
|
||||
|
@ -41,7 +41,7 @@ let module_name =
|
|||
|
||||
let module_names = list module_name >>| String.Set.of_list
|
||||
|
||||
let invalid_lib_name ~loc = of_sexp_errorf_loc loc "invalid library name"
|
||||
let invalid_lib_name ~loc = of_sexp_errorf loc "invalid library name"
|
||||
|
||||
let library_name =
|
||||
plain_string (fun ~loc name ->
|
||||
|
@ -61,17 +61,17 @@ let file =
|
|||
plain_string (fun ~loc s ->
|
||||
match s with
|
||||
| "." | ".." ->
|
||||
of_sexp_errorf_loc loc "'.' and '..' are not valid filenames"
|
||||
of_sexp_errorf loc "'.' and '..' are not valid filenames"
|
||||
| fn -> fn)
|
||||
|
||||
let file_in_current_dir =
|
||||
plain_string (fun ~loc s ->
|
||||
match s with
|
||||
| "." | ".." ->
|
||||
of_sexp_errorf_loc loc "'.' and '..' are not valid filenames"
|
||||
of_sexp_errorf loc "'.' and '..' are not valid filenames"
|
||||
| fn ->
|
||||
if Filename.dirname fn <> Filename.current_dir_name then
|
||||
of_sexp_errorf_loc loc "file in current directory expected"
|
||||
of_sexp_errorf loc "file in current directory expected"
|
||||
else
|
||||
fn)
|
||||
|
||||
|
@ -80,7 +80,7 @@ let relative_file =
|
|||
if Filename.is_relative fn then
|
||||
fn
|
||||
else
|
||||
of_sexp_errorf_loc loc "relative filename expected")
|
||||
of_sexp_errorf loc "relative filename expected")
|
||||
|
||||
let c_name, cxx_name =
|
||||
let make what ext =
|
||||
|
@ -88,7 +88,7 @@ let c_name, cxx_name =
|
|||
if match s with
|
||||
| "" | "." | ".." -> true
|
||||
| _ -> Filename.basename s <> s then
|
||||
of_sexp_errorf_loc loc
|
||||
of_sexp_errorf loc
|
||||
"%S is not a valid %s name.\n\
|
||||
Hint: To use %s files from another directory, use a \
|
||||
(copy_files <dir>/*.%s) stanza instead."
|
||||
|
@ -301,7 +301,7 @@ module Per_module = struct
|
|||
|> function
|
||||
| Ok t -> t
|
||||
| Error (name, _, _) ->
|
||||
of_sexp_errorf_loc loc
|
||||
of_sexp_errorf loc
|
||||
"module %s present in two different sets"
|
||||
(Module.Name.to_string name)
|
||||
]
|
||||
|
@ -384,7 +384,7 @@ module Lib_dep = struct
|
|||
junk >>> file >>| fun file ->
|
||||
let common = String.Set.inter required forbidden in
|
||||
Option.iter (String.Set.choose common) ~f:(fun name ->
|
||||
of_sexp_errorf_loc loc
|
||||
of_sexp_errorf loc
|
||||
"library %S is both required and forbidden in this clause"
|
||||
name);
|
||||
{ required
|
||||
|
@ -392,7 +392,7 @@ module Lib_dep = struct
|
|||
; file
|
||||
}
|
||||
| List _ ->
|
||||
of_sexp_errorf_loc loc "(<[!]libraries>... -> <file>) expected"
|
||||
of_sexp_errorf loc "(<[!]libraries>... -> <file>) expected"
|
||||
| (Atom (_, A s) | Quoted_string (_, s)) ->
|
||||
junk >>= fun () ->
|
||||
let len = String.length s in
|
||||
|
@ -417,7 +417,7 @@ module Lib_dep = struct
|
|||
repeat choice >>= fun choices ->
|
||||
return (Select { result_fn; choices; loc }))
|
||||
| sexp ->
|
||||
of_sexp_error sexp
|
||||
of_sexp_error (Sexp.Ast.loc sexp)
|
||||
"<library> or (select <module> from <libraries...>) expected"
|
||||
|
||||
let to_lib_names = function
|
||||
|
@ -450,16 +450,16 @@ module Lib_deps = struct
|
|||
| Some kind' ->
|
||||
match kind, kind' with
|
||||
| Required, Required ->
|
||||
of_sexp_errorf_loc loc "library %S is present twice" name
|
||||
of_sexp_errorf loc "library %S is present twice" name
|
||||
| (Optional|Forbidden), (Optional|Forbidden) ->
|
||||
acc
|
||||
| Optional, Required | Required, Optional ->
|
||||
of_sexp_errorf_loc loc
|
||||
of_sexp_errorf loc
|
||||
"library %S is present both as an optional \
|
||||
and required dependency"
|
||||
name
|
||||
| Forbidden, Required | Required, Forbidden ->
|
||||
of_sexp_errorf_loc loc
|
||||
of_sexp_errorf loc
|
||||
"library %S is present both as a forbidden \
|
||||
and required dependency"
|
||||
name
|
||||
|
@ -773,7 +773,7 @@ module Install_conf = struct
|
|||
| List (_, [Atom (_, A src); Atom (_, A "as"); Atom (_, A dst)]) ->
|
||||
junk >>> return { src; dst = Some dst }
|
||||
| sexp ->
|
||||
of_sexp_error sexp
|
||||
of_sexp_error (Sexp.Ast.loc sexp)
|
||||
"invalid format, <name> or (<name> as <install-as>) expected"
|
||||
|
||||
type t =
|
||||
|
@ -871,13 +871,13 @@ module Executables = struct
|
|||
let t =
|
||||
located (list t) >>| fun (loc, l) ->
|
||||
match l with
|
||||
| [] -> of_sexp_errorf_loc loc "No linking mode defined"
|
||||
| [] -> of_sexp_errorf loc "No linking mode defined"
|
||||
| l ->
|
||||
let t = of_list l in
|
||||
if (mem t native_exe && mem t exe ) ||
|
||||
(mem t native_object && mem t object_ ) ||
|
||||
(mem t native_shared_object && mem t shared_object) then
|
||||
of_sexp_errorf_loc loc
|
||||
of_sexp_errorf loc
|
||||
"It is not allowed use both native and best \
|
||||
for the same binary kind."
|
||||
else
|
||||
|
@ -1177,7 +1177,7 @@ module Alias_conf = struct
|
|||
let alias_name =
|
||||
plain_string (fun ~loc s ->
|
||||
if Filename.basename s <> s then
|
||||
of_sexp_errorf_loc loc "%S is not a valid alias name" s
|
||||
of_sexp_errorf loc "%S is not a valid alias name" s
|
||||
else
|
||||
s)
|
||||
|
||||
|
@ -1258,7 +1258,7 @@ module Env = struct
|
|||
in
|
||||
return (pat, configs))
|
||||
| sexp ->
|
||||
of_sexp_error sexp
|
||||
of_sexp_error (Sexp.Ast.loc sexp)
|
||||
"S-expression of the form (<profile> <fields>) expected"
|
||||
end
|
||||
|
||||
|
|
|
@ -72,7 +72,7 @@ end = struct
|
|||
let sexp_of_t t = Sexp.To_sexp.string (to_string t)
|
||||
let t = Sexp.Of_sexp.plain_string (fun ~loc t ->
|
||||
if Filename.is_relative t then
|
||||
Sexp.Of_sexp.of_sexp_errorf_loc loc "Absolute path expected"
|
||||
Sexp.Of_sexp.of_sexp_errorf loc "Absolute path expected"
|
||||
else
|
||||
of_string t)
|
||||
|
||||
|
|
|
@ -72,12 +72,10 @@ module Of_sexp = struct
|
|||
|
||||
exception Of_sexp of Loc.t * string * hint option
|
||||
|
||||
let of_sexp_error sexp ?hint msg =
|
||||
raise (Of_sexp (Ast.loc sexp, msg, hint))
|
||||
let of_sexp_errorf sexp ?hint fmt =
|
||||
Printf.ksprintf (fun msg -> of_sexp_error sexp ?hint msg) fmt
|
||||
let of_sexp_errorf_loc loc ?hint fmt =
|
||||
Printf.ksprintf (fun msg -> raise (Of_sexp (loc, msg, hint))) fmt
|
||||
let of_sexp_error ?hint loc msg =
|
||||
raise (Of_sexp (loc, msg, hint))
|
||||
let of_sexp_errorf ?hint loc fmt =
|
||||
Printf.ksprintf (fun msg -> of_sexp_error loc ?hint msg) fmt
|
||||
|
||||
type unparsed_field =
|
||||
{ values : Ast.t list
|
||||
|
@ -154,21 +152,21 @@ module Of_sexp = struct
|
|||
| sexp :: _ ->
|
||||
match cstr with
|
||||
| None ->
|
||||
of_sexp_errorf sexp "This value is unused"
|
||||
of_sexp_errorf (Ast.loc sexp) "This value is unused"
|
||||
| Some s ->
|
||||
of_sexp_errorf sexp "Too many argument for %s" s
|
||||
of_sexp_errorf (Ast.loc sexp) "Too many argument for %s" s
|
||||
end
|
||||
| Fields _ -> begin
|
||||
match Name_map.choose state.unparsed with
|
||||
| None -> v
|
||||
| Some (name, { entry; _ }) ->
|
||||
let name_sexp =
|
||||
let name_loc =
|
||||
match entry with
|
||||
| List (_, s :: _) -> s
|
||||
| List (_, s :: _) -> Ast.loc s
|
||||
| _ -> assert false
|
||||
in
|
||||
of_sexp_errorf ~hint:{ on = name; candidates = state.known }
|
||||
name_sexp "Unknown field %s" name
|
||||
name_loc "Unknown field %s" name
|
||||
end
|
||||
|
||||
let parse t sexp =
|
||||
|
@ -179,9 +177,9 @@ module Of_sexp = struct
|
|||
match cstr with
|
||||
| None ->
|
||||
let loc = { loc with start = loc.stop } in
|
||||
of_sexp_errorf_loc loc "Premature end of list"
|
||||
of_sexp_errorf loc "Premature end of list"
|
||||
| Some s ->
|
||||
of_sexp_errorf_loc loc "Not enough arguments for %s" s
|
||||
of_sexp_errorf loc "Not enough arguments for %s" s
|
||||
[@@inline never]
|
||||
|
||||
let next f ctx sexps =
|
||||
|
@ -200,7 +198,7 @@ module Of_sexp = struct
|
|||
let plain_string f =
|
||||
next (function
|
||||
| Atom (loc, A s) | Quoted_string (loc, s) -> f ~loc s
|
||||
| List _ as sexp -> of_sexp_error sexp "Atom or quoted string expected")
|
||||
| List (loc, _) -> of_sexp_error loc "Atom or quoted string expected")
|
||||
|
||||
let enter t =
|
||||
next (function
|
||||
|
@ -208,7 +206,7 @@ module Of_sexp = struct
|
|||
let ctx = Values (loc, None) in
|
||||
result ctx (t ctx l)
|
||||
| sexp ->
|
||||
of_sexp_error sexp "List expected")
|
||||
of_sexp_error (Ast.loc sexp) "List expected")
|
||||
|
||||
let fix f =
|
||||
let rec p = lazy (f r)
|
||||
|
@ -238,29 +236,22 @@ module Of_sexp = struct
|
|||
in
|
||||
search sexp rest
|
||||
|
||||
let of_sexp_error ?hint sexp str = raise (Of_sexp (Ast.loc sexp, str, hint))
|
||||
let of_sexp_errorf ?hint sexp fmt =
|
||||
Printf.ksprintf (of_sexp_error ?hint sexp) fmt
|
||||
|
||||
let of_sexp_errorf_loc ?hint loc fmt =
|
||||
Printf.ksprintf (fun s -> raise (Of_sexp (loc, s, hint))) fmt
|
||||
|
||||
let raw = next (fun x -> x)
|
||||
|
||||
let unit =
|
||||
next
|
||||
(function
|
||||
| List (_, []) -> ()
|
||||
| sexp -> of_sexp_error sexp "() expected")
|
||||
| sexp -> of_sexp_error (Ast.loc sexp) "() expected")
|
||||
|
||||
let basic desc f =
|
||||
next (function
|
||||
| List (loc, _) | Quoted_string (loc, _) ->
|
||||
of_sexp_errorf_loc loc "%s expected" desc
|
||||
of_sexp_errorf loc "%s expected" desc
|
||||
| Atom (loc, s) ->
|
||||
match f (Atom.to_string s) with
|
||||
| Error () ->
|
||||
of_sexp_errorf_loc loc "%s expected" desc
|
||||
of_sexp_errorf loc "%s expected" desc
|
||||
| Ok x -> x)
|
||||
|
||||
let string = plain_string (fun ~loc:_ x -> x)
|
||||
|
@ -306,7 +297,7 @@ module Of_sexp = struct
|
|||
| Ok x -> return x
|
||||
| Error (key, _v1, _v2) ->
|
||||
loc >>= fun loc ->
|
||||
of_sexp_errorf_loc loc "key %s present multiple times" key
|
||||
of_sexp_errorf loc "key %s present multiple times" key
|
||||
|
||||
let string_hashtbl t =
|
||||
string_map t >>| fun map ->
|
||||
|
@ -320,7 +311,7 @@ module Of_sexp = struct
|
|||
| Some t ->
|
||||
result ctx (t ctx values)
|
||||
| None ->
|
||||
of_sexp_errorf_loc loc
|
||||
of_sexp_errorf loc
|
||||
~hint:{ on = name
|
||||
; candidates = List.map cstrs ~f:fst
|
||||
}
|
||||
|
@ -331,25 +322,26 @@ module Of_sexp = struct
|
|||
match sexp with
|
||||
| Atom (loc, A s) ->
|
||||
find_cstr cstrs loc s (Values (loc, Some s)) []
|
||||
| Quoted_string _ ->
|
||||
of_sexp_error sexp "Atom expected"
|
||||
| List (_, []) ->
|
||||
of_sexp_error sexp "Non-empty list expected"
|
||||
| Quoted_string (loc, _) ->
|
||||
of_sexp_error loc "Atom expected"
|
||||
| List (loc, []) ->
|
||||
of_sexp_error loc "Non-empty list expected"
|
||||
| List (loc, name :: args) ->
|
||||
match name with
|
||||
| Quoted_string _ | List _ -> of_sexp_error name "Atom expected"
|
||||
| Quoted_string (loc, _) | List (loc, _) ->
|
||||
of_sexp_error loc "Atom expected"
|
||||
| Atom (s_loc, A s) ->
|
||||
find_cstr cstrs s_loc s (Values (loc, Some s)) args)
|
||||
|
||||
let enum cstrs =
|
||||
next (fun sexp ->
|
||||
match sexp with
|
||||
| Quoted_string _ | List _ -> of_sexp_error sexp "Atom expected"
|
||||
| Atom (_, A s) ->
|
||||
next (function
|
||||
| Quoted_string (loc, _)
|
||||
| List (loc, _) -> of_sexp_error loc "Atom expected"
|
||||
| Atom (loc, A s) ->
|
||||
match List.assoc cstrs s with
|
||||
| Some value -> value
|
||||
| None ->
|
||||
of_sexp_errorf sexp
|
||||
of_sexp_errorf loc
|
||||
~hint:{ on = s
|
||||
; candidates = List.map cstrs ~f:fst
|
||||
}
|
||||
|
@ -391,10 +383,10 @@ module Of_sexp = struct
|
|||
let last = List.fold_left l ~init:first ~f:(fun _ x -> x) in
|
||||
{ first with stop = last.stop }
|
||||
in
|
||||
of_sexp_errorf_loc loc "%s" msg
|
||||
of_sexp_errorf loc "%s" msg
|
||||
|
||||
let field_missing (Fields (loc, _)) name =
|
||||
of_sexp_errorf_loc loc "field %s missing" name
|
||||
of_sexp_errorf loc "field %s missing" name
|
||||
[@@inline never]
|
||||
|
||||
let rec multiple_occurrences ~name ~last ~prev =
|
||||
|
@ -403,7 +395,8 @@ module Of_sexp = struct
|
|||
(* Make the error message point to the second occurrence *)
|
||||
multiple_occurrences ~name ~last:prev ~prev:prev_prev
|
||||
| None ->
|
||||
of_sexp_errorf last.entry "Field %S is present too many times" name
|
||||
of_sexp_errorf (Ast.loc last.entry) "Field %S is present too many times"
|
||||
name
|
||||
[@@inline never]
|
||||
|
||||
let find_single state name =
|
||||
|
@ -464,11 +457,11 @@ module Of_sexp = struct
|
|||
; entry = sexp
|
||||
; prev = Name_map.find acc name
|
||||
}
|
||||
| List _ | Quoted_string _ ->
|
||||
of_sexp_error name_sexp "Atom expected"
|
||||
| List (loc, _) | Quoted_string (loc, _) ->
|
||||
of_sexp_error loc "Atom expected"
|
||||
end
|
||||
| _ ->
|
||||
of_sexp_error sexp
|
||||
of_sexp_error (Ast.loc sexp)
|
||||
"S-expression of the form (<name> <values>...) expected")
|
||||
in
|
||||
let ctx = Fields (loc, cstr) in
|
||||
|
|
|
@ -146,9 +146,16 @@ module Of_sexp : sig
|
|||
|
||||
val fix : ('a t -> 'a t) -> 'a t
|
||||
|
||||
val of_sexp_error : ?hint:hint -> Ast.t -> string -> _
|
||||
val of_sexp_errorf : ?hint:hint -> Ast.t -> ('a, unit, string, 'b) format4 -> 'a
|
||||
val of_sexp_errorf_loc : ?hint:hint -> Loc.t -> ('a, unit, string, 'b) format4 -> 'a
|
||||
val of_sexp_error
|
||||
: ?hint:hint
|
||||
-> Loc.t
|
||||
-> string
|
||||
-> _
|
||||
val of_sexp_errorf
|
||||
: ?hint:hint
|
||||
-> Loc.t
|
||||
-> ('a, unit, string, 'b) format4
|
||||
-> 'a
|
||||
|
||||
val located : 'a t -> (Loc.t * 'a) t
|
||||
|
||||
|
|
|
@ -66,7 +66,7 @@ let t =
|
|||
| Atom(loc, A s) -> { items = items_of_string s; loc; quoted = false }
|
||||
| Quoted_string (loc, s) ->
|
||||
{ items = items_of_string s; loc; quoted = true }
|
||||
| List _ as sexp -> of_sexp_error sexp "Atom or quoted string expected"
|
||||
| List (loc, _) -> of_sexp_error loc "Atom or quoted string expected"
|
||||
|
||||
let loc t = t.loc
|
||||
|
||||
|
|
|
@ -17,7 +17,7 @@ module Version = struct
|
|||
Loc.fail loc "Atom of the form NNN.NNN expected"
|
||||
end
|
||||
| sexp ->
|
||||
of_sexp_error sexp "Atom expected"
|
||||
of_sexp_error (Sexp.Ast.loc sexp) "Atom expected"
|
||||
|
||||
let can_read ~parser_version:(pa, pb) ~data_version:(da, db) =
|
||||
pa = da && db <= pb
|
||||
|
|
|
@ -155,14 +155,17 @@ let t ?x ?profile:cmdline_profile sexps =
|
|||
name = "install" ||
|
||||
String.contains name '/' ||
|
||||
String.contains name '\\' then
|
||||
of_sexp_errorf sexp "%S is not allowed as a build context name" name;
|
||||
of_sexp_errorf (Sexp.Ast.loc sexp)
|
||||
"%S is not allowed as a build context name" name;
|
||||
if String.Set.mem !defined_names name then
|
||||
of_sexp_errorf sexp "second definition of build context %S" name;
|
||||
of_sexp_errorf (Sexp.Ast.loc sexp)
|
||||
"second definition of build context %S" name;
|
||||
defined_names := String.Set.union !defined_names
|
||||
(String.Set.of_list (Context.all_names ctx));
|
||||
match ctx, t.merlin_context with
|
||||
| Opam { merlin = true; _ }, Some _ ->
|
||||
of_sexp_errorf sexp "you can only have one context for merlin"
|
||||
of_sexp_errorf (Sexp.Ast.loc sexp)
|
||||
"you can only have one context for merlin"
|
||||
| Opam { merlin = true; _ }, None ->
|
||||
{ merlin_context = Some name; contexts = ctx :: t.contexts }
|
||||
| _ ->
|
||||
|
|
Loading…
Reference in New Issue