matthieu
/
dune
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Reduce the number of of_sexp_error... functions 

Signed-off-by: Jeremie Dimino <jeremie@dimino.org>
This commit is contained in:
Jeremie Dimino 2018-06-18 18:06:32 +01:00
parent 30d20d6143
commit 14e6b1e038
12 changed files with 81 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
src/action.ml
View File

@ -329,7 +329,7 @@ module Unexpanded = struct
let open Sexp.Of_sexp in let open Sexp.Of_sexp in
peek raw >>= function peek raw >>= function
| Atom _ | Quoted_string _ as sexp -> | 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" "if you meant for this to be executed with bash, write (bash \"...\") instead"
| List _ -> t | List _ -> t
@ -593,7 +593,8 @@ module Promotion = struct
Path.t >>= fun dst -> Path.t >>= fun dst ->
return { src; dst }) return { src; dst })
| sexp -> | 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 } = let sexp_of_t { src; dst } =
Sexp.List [Path.sexp_of_t src; Sexp.unsafe_atom_of_string "as"; Sexp.List [Path.sexp_of_t src; Sexp.unsafe_atom_of_string "as";

2
src/config.ml
View File

@ -65,7 +65,7 @@ module Concurrency = struct
let t = let t =
plain_string (fun ~loc s -> plain_string (fun ~loc s ->
match of_string s with 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) | Ok s -> s)
let to_string = function let to_string = function

2
src/dune_project.ml
View File

@ -75,7 +75,7 @@ end = struct
if validate s then if validate s then
Named s Named s
else 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 let encode = function
| Named s -> s | Named s -> s

2
src/file_tree.ml
View File

@ -47,7 +47,7 @@ module Dune_file = struct
| "" | "." | ".." -> true | "" | "." | ".." -> true
| _ -> false | _ -> false
then then
of_sexp_errorf_loc loc "Invalid sub-directory name %S" dn of_sexp_errorf loc "Invalid sub-directory name %S" dn
else else
dn) dn)
in in

2
src/installed_dune_file.ml
View File

@ -32,7 +32,7 @@ let of_sexp =
plain_string (fun ~loc -> function plain_string (fun ~loc -> function
| "1" -> () | "1" -> ()
| _ -> | _ ->
of_sexp_errorf_loc loc of_sexp_errorf loc
"Unsupported version, only version 1 is supported") "Unsupported version, only version 1 is supported")
in in
sum sum

38
src/jbuild.ml
View File

@ -21,7 +21,7 @@ module Jbuild_version = struct
end end
let invalid_module_name ~loc = 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 = let module_name =
plain_string (fun ~loc name -> plain_string (fun ~loc name ->
@ -41,7 +41,7 @@ let module_name =
let module_names = list module_name >>| String.Set.of_list 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 = let library_name =
plain_string (fun ~loc name -> plain_string (fun ~loc name ->
@ -61,17 +61,17 @@ let file =
plain_string (fun ~loc s -> plain_string (fun ~loc s ->
match s with match s with
| "." | ".." -> | "." | ".." ->
of_sexp_errorf_loc loc "'.' and '..' are not valid filenames" of_sexp_errorf loc "'.' and '..' are not valid filenames"
| fn -> fn) | fn -> fn)
let file_in_current_dir = let file_in_current_dir =
plain_string (fun ~loc s -> plain_string (fun ~loc s ->
match s with match s with
| "." | ".." -> | "." | ".." ->
of_sexp_errorf_loc loc "'.' and '..' are not valid filenames" of_sexp_errorf loc "'.' and '..' are not valid filenames"
| fn -> | fn ->
if Filename.dirname fn <> Filename.current_dir_name then 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 else
fn) fn)
@ -80,7 +80,7 @@ let relative_file =
if Filename.is_relative fn then if Filename.is_relative fn then
fn fn
else else
of_sexp_errorf_loc loc "relative filename expected") of_sexp_errorf loc "relative filename expected")
let c_name, cxx_name = let c_name, cxx_name =
let make what ext = let make what ext =
@ -88,7 +88,7 @@ let c_name, cxx_name =
if match s with if match s with
| "" | "." | ".." -> true | "" | "." | ".." -> true
| _ -> Filename.basename s <> s then | _ -> Filename.basename s <> s then
of_sexp_errorf_loc loc of_sexp_errorf loc
"%S is not a valid %s name.\n\ "%S is not a valid %s name.\n\
Hint: To use %s files from another directory, use a \ Hint: To use %s files from another directory, use a \
(copy_files <dir>/*.%s) stanza instead." (copy_files <dir>/*.%s) stanza instead."
@ -301,7 +301,7 @@ module Per_module = struct
|> function |> function
| Ok t -> t | Ok t -> t
| Error (name, _, _) -> | Error (name, _, _) ->
of_sexp_errorf_loc loc of_sexp_errorf loc
"module %s present in two different sets" "module %s present in two different sets"
(Module.Name.to_string name) (Module.Name.to_string name)
] ]
@ -384,7 +384,7 @@ module Lib_dep = struct
junk >>> file >>| fun file -> junk >>> file >>| fun file ->
let common = String.Set.inter required forbidden in let common = String.Set.inter required forbidden in
Option.iter (String.Set.choose common) ~f:(fun name -> 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" "library %S is both required and forbidden in this clause"
name); name);
{ required { required
@ -392,7 +392,7 @@ module Lib_dep = struct
; file ; file
} }
| List _ -> | List _ ->
of_sexp_errorf_loc loc "(<[!]libraries>... -> <file>) expected" of_sexp_errorf loc "(<[!]libraries>... -> <file>) expected"
| (Atom (_, A s) | Quoted_string (_, s)) -> | (Atom (_, A s) | Quoted_string (_, s)) ->
junk >>= fun () -> junk >>= fun () ->
let len = String.length s in let len = String.length s in
@ -417,7 +417,7 @@ module Lib_dep = struct
repeat choice >>= fun choices -> repeat choice >>= fun choices ->
return (Select { result_fn; choices; loc })) return (Select { result_fn; choices; loc }))
| sexp -> | sexp ->
of_sexp_error sexp of_sexp_error (Sexp.Ast.loc sexp)
"<library> or (select <module> from <libraries...>) expected" "<library> or (select <module> from <libraries...>) expected"
let to_lib_names = function let to_lib_names = function
@ -450,16 +450,16 @@ module Lib_deps = struct
| Some kind' -> | Some kind' ->
match kind, kind' with match kind, kind' with
| Required, Required -> | 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) -> | (Optional|Forbidden), (Optional|Forbidden) ->
acc acc
| Optional, Required | Required, Optional -> | Optional, Required | Required, Optional ->
of_sexp_errorf_loc loc of_sexp_errorf loc
"library %S is present both as an optional \ "library %S is present both as an optional \
and required dependency" and required dependency"
name name
| Forbidden, Required | Required, Forbidden -> | Forbidden, Required | Required, Forbidden ->
of_sexp_errorf_loc loc of_sexp_errorf loc
"library %S is present both as a forbidden \ "library %S is present both as a forbidden \
and required dependency" and required dependency"
name name
@ -773,7 +773,7 @@ module Install_conf = struct
| List (_, [Atom (_, A src); Atom (_, A "as"); Atom (_, A dst)]) -> | List (_, [Atom (_, A src); Atom (_, A "as"); Atom (_, A dst)]) ->
junk >>> return { src; dst = Some dst } junk >>> return { src; dst = Some dst }
| sexp -> | sexp ->
of_sexp_error sexp of_sexp_error (Sexp.Ast.loc sexp)
"invalid format, <name> or (<name> as <install-as>) expected" "invalid format, <name> or (<name> as <install-as>) expected"
type t = type t =
@ -871,13 +871,13 @@ module Executables = struct
let t = let t =
located (list t) >>| fun (loc, l) -> located (list t) >>| fun (loc, l) ->
match l with match l with
| [] -> of_sexp_errorf_loc loc "No linking mode defined" | [] -> of_sexp_errorf loc "No linking mode defined"
| l -> | l ->
let t = of_list l in let t = of_list l in
if (mem t native_exe && mem t exe ) || if (mem t native_exe && mem t exe ) ||
(mem t native_object && mem t object_ ) || (mem t native_object && mem t object_ ) ||
(mem t native_shared_object && mem t shared_object) then (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 \ "It is not allowed use both native and best \
for the same binary kind." for the same binary kind."
else else
@ -1177,7 +1177,7 @@ module Alias_conf = struct
let alias_name = let alias_name =
plain_string (fun ~loc s -> plain_string (fun ~loc s ->
if Filename.basename s <> s then 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 else
s) s)
@ -1258,7 +1258,7 @@ module Env = struct
in in
return (pat, configs)) return (pat, configs))
| sexp -> | sexp ->
of_sexp_error sexp of_sexp_error (Sexp.Ast.loc sexp)
"S-expression of the form (<profile> <fields>) expected" "S-expression of the form (<profile> <fields>) expected"
end end

2
src/stdune/path.ml
View File

@ -72,7 +72,7 @@ end = struct
let sexp_of_t t = Sexp.To_sexp.string (to_string t) let sexp_of_t t = Sexp.To_sexp.string (to_string t)
let t = Sexp.Of_sexp.plain_string (fun ~loc t -> let t = Sexp.Of_sexp.plain_string (fun ~loc t ->
if Filename.is_relative t then 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 else
of_string t) of_string t)

79
src/stdune/sexp.ml
View File

@ -72,12 +72,10 @@ module Of_sexp = struct
exception Of_sexp of Loc.t * string * hint option exception Of_sexp of Loc.t * string * hint option
let of_sexp_error sexp ?hint msg = let of_sexp_error ?hint loc msg =
raise (Of_sexp (Ast.loc sexp, msg, hint)) raise (Of_sexp (loc, msg, hint))
let of_sexp_errorf sexp ?hint fmt = let of_sexp_errorf ?hint loc fmt =
Printf.ksprintf (fun msg -> of_sexp_error sexp ?hint msg) fmt Printf.ksprintf (fun msg -> of_sexp_error loc ?hint msg) fmt
let of_sexp_errorf_loc loc ?hint fmt =
Printf.ksprintf (fun msg -> raise (Of_sexp (loc, msg, hint))) fmt
type unparsed_field = type unparsed_field =
{ values : Ast.t list { values : Ast.t list
@ -154,21 +152,21 @@ module Of_sexp = struct
| sexp :: _ -> | sexp :: _ ->
match cstr with match cstr with
| None -> | None ->
of_sexp_errorf sexp "This value is unused" of_sexp_errorf (Ast.loc sexp) "This value is unused"
| Some s -> | 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 end
| Fields _ -> begin | Fields _ -> begin
match Name_map.choose state.unparsed with match Name_map.choose state.unparsed with
| None -> v | None -> v
| Some (name, { entry; _ }) -> | Some (name, { entry; _ }) ->
let name_sexp = let name_loc =
match entry with match entry with
| List (_, s :: _) -> s | List (_, s :: _) -> Ast.loc s
| _ -> assert false | _ -> assert false
in in
of_sexp_errorf ~hint:{ on = name; candidates = state.known } of_sexp_errorf ~hint:{ on = name; candidates = state.known }
name_sexp "Unknown field %s" name name_loc "Unknown field %s" name
end end
let parse t sexp = let parse t sexp =
@ -179,9 +177,9 @@ module Of_sexp = struct
match cstr with match cstr with
| None -> | None ->
let loc = { loc with start = loc.stop } in 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 -> | 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] [@@inline never]
let next f ctx sexps = let next f ctx sexps =
@ -200,7 +198,7 @@ module Of_sexp = struct
let plain_string f = let plain_string f =
next (function next (function
| Atom (loc, A s) | Quoted_string (loc, s) -> f ~loc s | 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 = let enter t =
next (function next (function
@ -208,7 +206,7 @@ module Of_sexp = struct
let ctx = Values (loc, None) in let ctx = Values (loc, None) in
result ctx (t ctx l) result ctx (t ctx l)
| sexp -> | sexp ->
of_sexp_error sexp "List expected") of_sexp_error (Ast.loc sexp) "List expected")
let fix f = let fix f =
let rec p = lazy (f r) let rec p = lazy (f r)
@ -238,29 +236,22 @@ module Of_sexp = struct
in in
search sexp rest 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 raw = next (fun x -> x)
let unit = let unit =
next next
(function (function
| List (_, []) -> () | List (_, []) -> ()
| sexp -> of_sexp_error sexp "() expected") | sexp -> of_sexp_error (Ast.loc sexp) "() expected")
let basic desc f = let basic desc f =
next (function next (function
| List (loc, _) | Quoted_string (loc, _) -> | List (loc, _) | Quoted_string (loc, _) ->
of_sexp_errorf_loc loc "%s expected" desc of_sexp_errorf loc "%s expected" desc
| Atom (loc, s) -> | Atom (loc, s) ->
match f (Atom.to_string s) with match f (Atom.to_string s) with
| Error () -> | Error () ->
of_sexp_errorf_loc loc "%s expected" desc of_sexp_errorf loc "%s expected" desc
| Ok x -> x) | Ok x -> x)
let string = plain_string (fun ~loc:_ x -> x) let string = plain_string (fun ~loc:_ x -> x)
@ -306,7 +297,7 @@ module Of_sexp = struct
| Ok x -> return x | Ok x -> return x
| Error (key, _v1, _v2) -> | Error (key, _v1, _v2) ->
loc >>= fun loc -> 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 = let string_hashtbl t =
string_map t >>| fun map -> string_map t >>| fun map ->
@ -320,7 +311,7 @@ module Of_sexp = struct
| Some t -> | Some t ->
result ctx (t ctx values) result ctx (t ctx values)
| None -> | None ->
of_sexp_errorf_loc loc of_sexp_errorf loc
~hint:{ on = name ~hint:{ on = name
; candidates = List.map cstrs ~f:fst ; candidates = List.map cstrs ~f:fst
} }
@ -331,25 +322,26 @@ module Of_sexp = struct
match sexp with match sexp with
| Atom (loc, A s) -> | Atom (loc, A s) ->
find_cstr cstrs loc s (Values (loc, Some s)) [] find_cstr cstrs loc s (Values (loc, Some s)) []
| Quoted_string _ -> | Quoted_string (loc, _) ->
of_sexp_error sexp "Atom expected" of_sexp_error loc "Atom expected"
| List (_, []) -> | List (loc, []) ->
of_sexp_error sexp "Non-empty list expected" of_sexp_error loc "Non-empty list expected"
| List (loc, name :: args) -> | List (loc, name :: args) ->
match name with 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) -> | Atom (s_loc, A s) ->
find_cstr cstrs s_loc s (Values (loc, Some s)) args) find_cstr cstrs s_loc s (Values (loc, Some s)) args)
let enum cstrs = let enum cstrs =
next (fun sexp -> next (function
match sexp with | Quoted_string (loc, _)
| Quoted_string _ | List _ -> of_sexp_error sexp "Atom expected" | List (loc, _) -> of_sexp_error loc "Atom expected"
| Atom (_, A s) -> | Atom (loc, A s) ->
match List.assoc cstrs s with match List.assoc cstrs s with
| Some value -> value | Some value -> value
| None -> | None ->
of_sexp_errorf sexp of_sexp_errorf loc
~hint:{ on = s ~hint:{ on = s
; candidates = List.map cstrs ~f:fst ; 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 let last = List.fold_left l ~init:first ~f:(fun _ x -> x) in
{ first with stop = last.stop } { first with stop = last.stop }
in in
of_sexp_errorf_loc loc "%s" msg of_sexp_errorf loc "%s" msg
let field_missing (Fields (loc, _)) name = 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] [@@inline never]
let rec multiple_occurrences ~name ~last ~prev = let rec multiple_occurrences ~name ~last ~prev =
@ -403,7 +395,8 @@ module Of_sexp = struct
(* Make the error message point to the second occurrence *) (* Make the error message point to the second occurrence *)
multiple_occurrences ~name ~last:prev ~prev:prev_prev multiple_occurrences ~name ~last:prev ~prev:prev_prev
| None -> | 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] [@@inline never]
let find_single state name = let find_single state name =
@ -464,11 +457,11 @@ module Of_sexp = struct
; entry = sexp ; entry = sexp
; prev = Name_map.find acc name ; prev = Name_map.find acc name
} }
| List _ | Quoted_string _ -> | List (loc, _) | Quoted_string (loc, _) ->
of_sexp_error name_sexp "Atom expected" of_sexp_error loc "Atom expected"
end end
| _ -> | _ ->
of_sexp_error sexp of_sexp_error (Ast.loc sexp)
"S-expression of the form (<name> <values>...) expected") "S-expression of the form (<name> <values>...) expected")
in in
let ctx = Fields (loc, cstr) in let ctx = Fields (loc, cstr) in

13
src/stdune/sexp.mli
View File

@ -146,9 +146,16 @@ module Of_sexp : sig
val fix : ('a t -> 'a t) -> 'a t val fix : ('a t -> 'a t) -> 'a t
val of_sexp_error : ?hint:hint -> Ast.t -> string -> _ val of_sexp_error
val of_sexp_errorf : ?hint:hint -> Ast.t -> ('a, unit, string, 'b) format4 -> 'a : ?hint:hint
val of_sexp_errorf_loc : ?hint:hint -> Loc.t -> ('a, unit, string, 'b) format4 -> 'a -> 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 val located : 'a t -> (Loc.t * 'a) t

2
src/string_with_vars.ml
View File

@ -66,7 +66,7 @@ let t =
| Atom(loc, A s) -> { items = items_of_string s; loc; quoted = false } | Atom(loc, A s) -> { items = items_of_string s; loc; quoted = false }
| Quoted_string (loc, s) -> | Quoted_string (loc, s) ->
{ items = items_of_string s; loc; quoted = true } { 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 let loc t = t.loc

2
src/syntax.ml
View File

@ -17,7 +17,7 @@ module Version = struct
Loc.fail loc "Atom of the form NNN.NNN expected" Loc.fail loc "Atom of the form NNN.NNN expected"
end end
| sexp -> | 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) = let can_read ~parser_version:(pa, pb) ~data_version:(da, db) =
pa = da && db <= pb pa = da && db <= pb

9
src/workspace.ml
View File

@ -155,14 +155,17 @@ let t ?x ?profile:cmdline_profile sexps =
name = "install" || name = "install" ||
String.contains name '/' || String.contains name '/' ||
String.contains name '\\' then 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 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 defined_names := String.Set.union !defined_names
(String.Set.of_list (Context.all_names ctx)); (String.Set.of_list (Context.all_names ctx));
match ctx, t.merlin_context with match ctx, t.merlin_context with
| Opam { merlin = true; _ }, Some _ -> | 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 -> | Opam { merlin = true; _ }, None ->
{ merlin_context = Some name; contexts = ctx :: t.contexts } { merlin_context = Some name; contexts = ctx :: t.contexts }
| _ -> | _ ->