diff --git a/src/action.ml b/src/action.ml index 7950d931..3228298f 100644 --- a/src/action.ml +++ b/src/action.ml @@ -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 "( as ) expected" + Sexp.Of_sexp.of_sexp_errorf (Sexp.Ast.loc sexp) + "( as ) expected" let sexp_of_t { src; dst } = Sexp.List [Path.sexp_of_t src; Sexp.unsafe_atom_of_string "as"; diff --git a/src/config.ml b/src/config.ml index 65f2178c..61a87c66 100644 --- a/src/config.ml +++ b/src/config.ml @@ -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 diff --git a/src/dune_project.ml b/src/dune_project.ml index e26d5a23..ab28c0db 100644 --- a/src/dune_project.ml +++ b/src/dune_project.ml @@ -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 diff --git a/src/file_tree.ml b/src/file_tree.ml index e82ef112..d49cb736 100644 --- a/src/file_tree.ml +++ b/src/file_tree.ml @@ -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 diff --git a/src/installed_dune_file.ml b/src/installed_dune_file.ml index 6ba2a2b5..b00d02a1 100644 --- a/src/installed_dune_file.ml +++ b/src/installed_dune_file.ml @@ -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 diff --git a/src/jbuild.ml b/src/jbuild.ml index d8647f2f..992e99e3 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -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 /*.%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>... -> ) expected" + of_sexp_errorf loc "(<[!]libraries>... -> ) 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) " or (select from ) 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, or ( 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 ( ) expected" end diff --git a/src/stdune/path.ml b/src/stdune/path.ml index 39997b27..74892c46 100644 --- a/src/stdune/path.ml +++ b/src/stdune/path.ml @@ -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) diff --git a/src/stdune/sexp.ml b/src/stdune/sexp.ml index ce991feb..73b922cf 100644 --- a/src/stdune/sexp.ml +++ b/src/stdune/sexp.ml @@ -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 ( ...) expected") in let ctx = Fields (loc, cstr) in diff --git a/src/stdune/sexp.mli b/src/stdune/sexp.mli index 5e70ff03..38ba5b76 100644 --- a/src/stdune/sexp.mli +++ b/src/stdune/sexp.mli @@ -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 diff --git a/src/string_with_vars.ml b/src/string_with_vars.ml index cb68657a..d757ff69 100644 --- a/src/string_with_vars.ml +++ b/src/string_with_vars.ml @@ -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 diff --git a/src/syntax.ml b/src/syntax.ml index fcbbc9c1..5ec25bec 100644 --- a/src/syntax.ml +++ b/src/syntax.ml @@ -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 diff --git a/src/workspace.ml b/src/workspace.ml index a39dcab7..e584b440 100644 --- a/src/workspace.ml +++ b/src/workspace.ml @@ -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 } | _ ->