Simplify the API for capturing the location of constructors
This commit is contained in:
parent
d22eebf5a1
commit
b48b1a168b
|
@ -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 ->
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -341,6 +341,7 @@ 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
|
||||
|
@ -348,6 +349,7 @@ module Of_sexp = struct
|
|||
match t, sexps with
|
||||
| Nil, [] -> f
|
||||
| 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 =
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 =
|
||||
|
|
Loading…
Reference in New Issue