Simplify the API for capturing the location of constructors

src/action.ml

@@ -49,7 +49,7 @@ struct
       *)
       ; cstr "copy#" (path @> path @> nil) (fun src dst ->
           Copy_and_add_line_directive (src, dst))
-      ; cstr_loc "copy-and-add-line-directive" (path @> path @> nil) (fun loc src dst ->
+      ; cstr "copy-and-add-line-directive" (cstr_loc (path @> path @> nil)) (fun loc src dst ->
           Loc.warn loc "copy-and-add-line-directive is deprecated, use copy# instead";
           Copy_and_add_line_directive (src, dst))
       ; cstr "copy#" (path @> path @> nil) (fun src dst ->

src/jbuild.ml

@@ -1252,12 +1252,12 @@ module Stanzas = struct
       [ cstr "library"     (Library.v1 project @> nil) (fun x -> [Library x])
       ; cstr "executable"  (Executables.v1_single project @> nil) execs
       ; cstr "executables" (Executables.v1_multi  project @> nil) execs
-      ; cstr_loc "rule"      (Rule.v1     @> nil) (fun loc x -> [Rule { x with loc }])
-      ; cstr_loc "ocamllex" (Rule.ocamllex_v1 @> nil)
+      ; cstr "rule"        (cstr_loc (Rule.v1 @> nil)) (fun loc x -> [Rule { x with loc }])
+      ; cstr "ocamllex"    (cstr_loc (Rule.ocamllex_v1 @> nil))
           (fun loc x -> rules (Rule.ocamllex_to_rule loc x))
-      ; cstr_loc "ocamlyacc" (Rule.ocamlyacc_v1 @> nil)
+      ; cstr "ocamlyacc"   (cstr_loc (Rule.ocamlyacc_v1 @> nil))
           (fun loc x -> rules (Rule.ocamlyacc_to_rule loc x))
-      ; cstr_loc "menhir" (Menhir.v1 @> nil)
+      ; cstr "menhir"      (cstr_loc (Menhir.v1 @> nil))
           (fun loc x -> [Menhir { x with loc }])
       ; cstr "install"     (Install_conf.v1 project @> nil) (fun x -> [Install     x])
       ; cstr "alias"       (Alias_conf.v1 project @> nil)   (fun x -> [Alias       x])
@@ -1265,11 +1265,11 @@ module Stanzas = struct
           (fun glob -> [Copy_files {add_line_directive = false; glob}])
       ; cstr "copy_files#" (Copy_files.v1 @> nil)
           (fun glob -> [Copy_files {add_line_directive = true; glob}])
-      ; cstr_loc "env" (rest Env.rule)
+      ; cstr "env" (cstr_loc (rest Env.rule))
           (fun loc rules -> [Env { loc; rules }])
       (* Just for validation and error messages *)
       ; cstr "jbuild_version" (Jbuild_version.t @> nil) (fun _ -> [])
-      ; cstr_loc "include" (relative_file @> nil) (fun loc fn ->
+      ; cstr "include" (cstr_loc (relative_file @> nil)) (fun loc fn ->
           let include_stack = (loc, file) :: include_stack in
           let dir = Path.parent_exn file in
           let file = Path.relative dir fn in

src/stdune/sexp.ml

@@ -341,13 +341,15 @@ module Of_sexp = struct
     type ('a, 'b) t =
       | Nil  : ('a, 'a) t
       | Rest : 'a conv -> ('a  list -> 'b, 'b) t
+      | Loc  : ('a, 'b) t -> (Loc.t -> 'a, 'b) t
       | Cons : 'a conv * ('b, 'c) t -> ('a -> 'b, 'c) t
 
     let rec convert : type a b. (a, b) t -> Ast.t -> Ast.t list -> a -> b
       = fun t sexp sexps f ->
         match t, sexps with
         | Nil, [] -> f
-        | Rest conv, l  -> f (List.map l ~f:conv)
+        | Rest conv, l -> f (List.map l ~f:conv)
+        | Loc t, sexps -> convert t sexp sexps (f (Ast.loc sexp))
         | Cons (conv, t), s :: sexps -> convert t sexp sexps (f (conv s))
         | Cons _, [] -> of_sexp_error sexp "not enough arguments"
         | Nil, _ :: _ -> of_sexp_error sexp "too many arguments"
@@ -356,6 +358,7 @@ module Of_sexp = struct
   let nil = Constructor_args_spec.Nil
   let ( @> ) a b = Constructor_args_spec.Cons (a, b)
   let rest f = Constructor_args_spec.Rest f
+  let cstr_loc x = Constructor_args_spec.Loc x
 
   let field_multi name ?default args_spec f state =
     match find_single state name with
@@ -384,7 +387,7 @@ module Of_sexp = struct
     type ('a, 'b) tuple =
       { name : string
       ; args : ('a, 'b) Constructor_args_spec.t
-      ; make : Loc.t -> 'a
+      ; make : 'a
       }
 
     type 'a record =
@@ -402,15 +405,12 @@ module Of_sexp = struct
   end
   module C = Constructor_spec
 
-  let cstr_loc name args make =
+  let cstr name args make =
     C.Tuple { name; args; make }
 
   let cstr_record name parse =
     C.Record { name; parse }
 
-  let cstr name args make =
-    cstr_loc name args (fun _ -> make)
-
   let equal_cstr_name a b = Name.compare a b = Eq
 
   let find_cstr cstrs sexp name =
@@ -429,9 +429,9 @@ module Of_sexp = struct
 
   let sum cstrs sexp =
     match sexp with
-    | Atom (loc, A s) -> begin
+    | Atom (_, A s) -> begin
         match find_cstr cstrs sexp s with
-        | C.Tuple  t -> Constructor_args_spec.convert t.args sexp [] (t.make loc)
+        | C.Tuple  t -> Constructor_args_spec.convert t.args sexp [] t.make
         | C.Record _ -> of_sexp_error sexp "'%s' expect arguments"
       end
     | Quoted_string _ -> of_sexp_error sexp "Atom expected"
@@ -441,8 +441,7 @@ module Of_sexp = struct
       | Quoted_string _ | List _ -> of_sexp_error name_sexp "Atom expected"
       | Atom (_, A s) ->
         match find_cstr cstrs sexp s with
-        | C.Tuple  t -> Constructor_args_spec.convert t.args sexp args
-                          (t.make loc)
+        | C.Tuple  t -> Constructor_args_spec.convert t.args sexp args t.make
         | C.Record r -> record r.parse (List (loc, args))
 
   let enum cstrs sexp =

src/stdune/sexp.mli

@@ -129,8 +129,15 @@ module Of_sexp : sig
     :  'a t
     -> ('b, 'c) Constructor_args_spec.t
     -> ('a -> 'b, 'c) Constructor_args_spec.t
+
+  (** Parse all remaining arguments using the following parser *)
   val rest : 'a t -> ('a list -> 'b, 'b) Constructor_args_spec.t
 
+  (** Capture the location of the constructor *)
+  val cstr_loc
+    :  ('a, 'b) Constructor_args_spec.t
+    -> (Loc.t -> 'a, 'b) Constructor_args_spec.t
+
   (** Field that takes multiple values *)
   val field_multi
     :  string
@@ -147,15 +154,15 @@ module Of_sexp : sig
     -> 'a
     -> 'b list record_parser
 
-  val cstr : string -> ('a, 'b) Constructor_args_spec.t -> 'a -> 'b Constructor_spec.t
-
-  val cstr_record : string -> 'a record_parser -> 'a Constructor_spec.t
-
-  val cstr_loc
+  val cstr
     :  string
     -> ('a, 'b) Constructor_args_spec.t
-    -> (Loc.t -> 'a)
+    -> 'a
     -> 'b Constructor_spec.t
+  val cstr_record
+    :  string
+    -> 'a record_parser
+    -> 'a Constructor_spec.t
 
   val sum
     :  'a Constructor_spec.t list

src/workspace.ml

@@ -95,7 +95,7 @@ type item = Context of Sexp.Ast.t | Profile of Loc.t * string
 let item_of_sexp =
   sum
     [ cstr "context" (raw @> nil) (fun x -> Context x)
-    ; cstr_loc "profile" (string @> nil) (fun loc x -> Profile (loc, x))
+    ; cstr "profile" (cstr_loc (string @> nil)) (fun loc x -> Profile (loc, x))
     ]
 
 let t ?x ?profile:cmdline_profile sexps =