Reduce the number of of_sexp_error... functions

Signed-off-by: Jeremie Dimino <jeremie@dimino.org>

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 "(<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";

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

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

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

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

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 <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
 

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)
 

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 (<name> <values>...) expected")
     in
     let ctx = Fields (loc, cstr) in

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
 

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
 

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

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 }
       | _ ->