diff --git a/src/action.ml b/src/action.ml index 6255d017..dd0b02ef 100644 --- a/src/action.ml +++ b/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 -> diff --git a/src/jbuild.ml b/src/jbuild.ml index 5286d337..efc6082d 100644 --- a/src/jbuild.ml +++ b/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 diff --git a/src/stdune/sexp.ml b/src/stdune/sexp.ml index 45103d4f..f29dbee2 100644 --- a/src/stdune/sexp.ml +++ b/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 = diff --git a/src/stdune/sexp.mli b/src/stdune/sexp.mli index 329355b4..8d3bf849 100644 --- a/src/stdune/sexp.mli +++ b/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 diff --git a/src/workspace.ml b/src/workspace.ml index 7af6068b..a42d3c21 100644 --- a/src/workspace.ml +++ b/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 =