Simplify the API for parsing remaining arguments of constructors
This commit is contained in:
parent
34ec6e050d
commit
d22eebf5a1
|
@ -30,7 +30,7 @@ struct
|
||||||
let rec t sexp =
|
let rec t sexp =
|
||||||
let path = Path.t and string = String.t in
|
let path = Path.t and string = String.t in
|
||||||
sum
|
sum
|
||||||
[ cstr_rest "run" (Program.t @> nil) string (fun prog args -> Run (prog, args))
|
[ cstr "run" (Program.t @> rest string) (fun prog args -> Run (prog, args))
|
||||||
; cstr "chdir" (path @> t @> nil) (fun dn t -> Chdir (dn, t))
|
; cstr "chdir" (path @> t @> nil) (fun dn t -> Chdir (dn, t))
|
||||||
; cstr "setenv" (string @> string @> t @> nil) (fun k v t -> Setenv (k, v, t))
|
; cstr "setenv" (string @> string @> t @> nil) (fun k v t -> Setenv (k, v, t))
|
||||||
; cstr "with-stdout-to" (path @> t @> nil) (fun fn t -> Redirect (Stdout, fn, t))
|
; cstr "with-stdout-to" (path @> t @> nil) (fun fn t -> Redirect (Stdout, fn, t))
|
||||||
|
@ -39,7 +39,7 @@ struct
|
||||||
; cstr "ignore-stdout" (t @> nil) (fun t -> Ignore (Stdout, t))
|
; cstr "ignore-stdout" (t @> nil) (fun t -> Ignore (Stdout, t))
|
||||||
; cstr "ignore-stderr" (t @> nil) (fun t -> Ignore (Stderr, t))
|
; cstr "ignore-stderr" (t @> nil) (fun t -> Ignore (Stderr, t))
|
||||||
; cstr "ignore-outputs" (t @> nil) (fun t -> Ignore (Outputs, t))
|
; cstr "ignore-outputs" (t @> nil) (fun t -> Ignore (Outputs, t))
|
||||||
; cstr_rest "progn" nil t (fun l -> Progn l)
|
; cstr "progn" (rest t) (fun l -> Progn l)
|
||||||
; cstr "echo" (string @> nil) (fun x -> Echo x)
|
; cstr "echo" (string @> nil) (fun x -> Echo x)
|
||||||
; cstr "cat" (path @> nil) (fun x -> Cat x)
|
; cstr "cat" (path @> nil) (fun x -> Cat x)
|
||||||
; cstr "copy" (path @> path @> nil) (fun src dst -> Copy (src, dst))
|
; cstr "copy" (path @> path @> nil) (fun src dst -> Copy (src, dst))
|
||||||
|
|
|
@ -1265,7 +1265,7 @@ module Stanzas = struct
|
||||||
(fun glob -> [Copy_files {add_line_directive = false; glob}])
|
(fun glob -> [Copy_files {add_line_directive = false; glob}])
|
||||||
; cstr "copy_files#" (Copy_files.v1 @> nil)
|
; cstr "copy_files#" (Copy_files.v1 @> nil)
|
||||||
(fun glob -> [Copy_files {add_line_directive = true; glob}])
|
(fun glob -> [Copy_files {add_line_directive = true; glob}])
|
||||||
; cstr_rest_loc "env" nil Env.rule
|
; cstr_loc "env" (rest Env.rule)
|
||||||
(fun loc rules -> [Env { loc; rules }])
|
(fun loc rules -> [Env { loc; rules }])
|
||||||
(* Just for validation and error messages *)
|
(* Just for validation and error messages *)
|
||||||
; cstr "jbuild_version" (Jbuild_version.t @> nil) (fun _ -> [])
|
; cstr "jbuild_version" (Jbuild_version.t @> nil) (fun _ -> [])
|
||||||
|
|
|
@ -336,35 +336,31 @@ module Of_sexp = struct
|
||||||
of_sexp_errorf ~hint:({ on = name ; candidates = state.known})
|
of_sexp_errorf ~hint:({ on = name ; candidates = state.known})
|
||||||
name_sexp "Unknown field %s" name
|
name_sexp "Unknown field %s" name
|
||||||
|
|
||||||
type ('a, 'b) rest =
|
|
||||||
| No_rest : ('a, 'a) rest
|
|
||||||
| Many : 'a t -> ('a list -> 'b, 'b) rest
|
|
||||||
|
|
||||||
module Constructor_args_spec = struct
|
module Constructor_args_spec = struct
|
||||||
type 'a conv = 'a t
|
type 'a conv = 'a t
|
||||||
type ('a, 'b) t =
|
type ('a, 'b) t =
|
||||||
| Nil : ('a, 'a) t
|
| Nil : ('a, 'a) t
|
||||||
|
| Rest : 'a conv -> ('a list -> 'b, 'b) t
|
||||||
| Cons : 'a conv * ('b, 'c) t -> ('a -> 'b, 'c) t
|
| Cons : 'a conv * ('b, 'c) t -> ('a -> 'b, 'c) t
|
||||||
|
|
||||||
let rec convert : type a b c. (a, b) t -> (b, c) rest -> Ast.t -> Ast.t list -> a -> c
|
let rec convert : type a b. (a, b) t -> Ast.t -> Ast.t list -> a -> b
|
||||||
= fun t rest sexp sexps f ->
|
= fun t sexp sexps f ->
|
||||||
match t, rest, sexps with
|
match t, sexps with
|
||||||
| Nil, No_rest, [] -> f
|
| Nil, [] -> f
|
||||||
| Nil, Many _ , [] -> f []
|
| Rest conv, l -> f (List.map l ~f:conv)
|
||||||
| Cons _, _, [] -> of_sexp_error sexp "not enough arguments"
|
| Cons (conv, t), s :: sexps -> convert t sexp sexps (f (conv s))
|
||||||
| Nil, No_rest, _ :: _ -> of_sexp_error sexp "too many arguments"
|
| Cons _, [] -> of_sexp_error sexp "not enough arguments"
|
||||||
| Nil, Many conv, l -> f (List.map l ~f:conv)
|
| Nil, _ :: _ -> of_sexp_error sexp "too many arguments"
|
||||||
| Cons (conv, t), _, s :: sexps ->
|
|
||||||
convert t rest sexp sexps (f (conv s))
|
|
||||||
end
|
end
|
||||||
|
|
||||||
let nil = Constructor_args_spec.Nil
|
let nil = Constructor_args_spec.Nil
|
||||||
let ( @> ) a b = Constructor_args_spec.Cons (a, b)
|
let ( @> ) a b = Constructor_args_spec.Cons (a, b)
|
||||||
|
let rest f = Constructor_args_spec.Rest f
|
||||||
|
|
||||||
let field_multi name ?default args_spec f state =
|
let field_multi name ?default args_spec f state =
|
||||||
match find_single state name with
|
match find_single state name with
|
||||||
| Some { values; entry; _ } ->
|
| Some { values; entry; _ } ->
|
||||||
(Constructor_args_spec.convert args_spec No_rest entry values f,
|
(Constructor_args_spec.convert args_spec entry values f,
|
||||||
consume name state)
|
consume name state)
|
||||||
| None ->
|
| None ->
|
||||||
match default with
|
match default with
|
||||||
|
@ -377,7 +373,7 @@ module Of_sexp = struct
|
||||||
| None -> acc
|
| None -> acc
|
||||||
| Some { values; entry; prev } ->
|
| Some { values; entry; prev } ->
|
||||||
let x =
|
let x =
|
||||||
Constructor_args_spec.convert args_spec No_rest entry values f
|
Constructor_args_spec.convert args_spec entry values f
|
||||||
in
|
in
|
||||||
loop (x :: acc) prev
|
loop (x :: acc) prev
|
||||||
in
|
in
|
||||||
|
@ -385,10 +381,9 @@ module Of_sexp = struct
|
||||||
(res, consume name state)
|
(res, consume name state)
|
||||||
|
|
||||||
module Constructor_spec = struct
|
module Constructor_spec = struct
|
||||||
type ('a, 'b, 'c) tuple =
|
type ('a, 'b) tuple =
|
||||||
{ name : string
|
{ name : string
|
||||||
; args : ('a, 'b) Constructor_args_spec.t
|
; args : ('a, 'b) Constructor_args_spec.t
|
||||||
; rest : ('b, 'c) rest
|
|
||||||
; make : Loc.t -> 'a
|
; make : Loc.t -> 'a
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -398,8 +393,8 @@ module Of_sexp = struct
|
||||||
}
|
}
|
||||||
|
|
||||||
type 'a t =
|
type 'a t =
|
||||||
| Tuple : (_, _, 'a) tuple -> 'a t
|
| Tuple : (_, 'a) tuple -> 'a t
|
||||||
| Record : 'a record -> 'a t
|
| Record : 'a record -> 'a t
|
||||||
|
|
||||||
let name = function
|
let name = function
|
||||||
| Tuple x -> x.name
|
| Tuple x -> x.name
|
||||||
|
@ -408,9 +403,7 @@ module Of_sexp = struct
|
||||||
module C = Constructor_spec
|
module C = Constructor_spec
|
||||||
|
|
||||||
let cstr_loc name args make =
|
let cstr_loc name args make =
|
||||||
C.Tuple { name; args; make; rest = No_rest }
|
C.Tuple { name; args; make }
|
||||||
let cstr_rest_loc name args rest make =
|
|
||||||
C.Tuple { name; args; make; rest = Many rest }
|
|
||||||
|
|
||||||
let cstr_record name parse =
|
let cstr_record name parse =
|
||||||
C.Record { name; parse }
|
C.Record { name; parse }
|
||||||
|
@ -418,9 +411,6 @@ module Of_sexp = struct
|
||||||
let cstr name args make =
|
let cstr name args make =
|
||||||
cstr_loc name args (fun _ -> make)
|
cstr_loc name args (fun _ -> make)
|
||||||
|
|
||||||
let cstr_rest name args rest make =
|
|
||||||
cstr_rest_loc name args rest (fun _ -> make)
|
|
||||||
|
|
||||||
let equal_cstr_name a b = Name.compare a b = Eq
|
let equal_cstr_name a b = Name.compare a b = Eq
|
||||||
|
|
||||||
let find_cstr cstrs sexp name =
|
let find_cstr cstrs sexp name =
|
||||||
|
@ -441,7 +431,7 @@ module Of_sexp = struct
|
||||||
match sexp with
|
match sexp with
|
||||||
| Atom (loc, A s) -> begin
|
| Atom (loc, A s) -> begin
|
||||||
match find_cstr cstrs sexp s with
|
match find_cstr cstrs sexp s with
|
||||||
| C.Tuple t -> Constructor_args_spec.convert t.args t.rest sexp [] (t.make loc)
|
| C.Tuple t -> Constructor_args_spec.convert t.args sexp [] (t.make loc)
|
||||||
| C.Record _ -> of_sexp_error sexp "'%s' expect arguments"
|
| C.Record _ -> of_sexp_error sexp "'%s' expect arguments"
|
||||||
end
|
end
|
||||||
| Quoted_string _ -> of_sexp_error sexp "Atom expected"
|
| Quoted_string _ -> of_sexp_error sexp "Atom expected"
|
||||||
|
@ -451,7 +441,8 @@ module Of_sexp = struct
|
||||||
| Quoted_string _ | List _ -> of_sexp_error name_sexp "Atom expected"
|
| Quoted_string _ | List _ -> of_sexp_error name_sexp "Atom expected"
|
||||||
| Atom (_, A s) ->
|
| Atom (_, A s) ->
|
||||||
match find_cstr cstrs sexp s with
|
match find_cstr cstrs sexp s with
|
||||||
| C.Tuple t -> Constructor_args_spec.convert t.args t.rest sexp args (t.make loc)
|
| C.Tuple t -> Constructor_args_spec.convert t.args sexp args
|
||||||
|
(t.make loc)
|
||||||
| C.Record r -> record r.parse (List (loc, args))
|
| C.Record r -> record r.parse (List (loc, args))
|
||||||
|
|
||||||
let enum cstrs sexp =
|
let enum cstrs sexp =
|
||||||
|
|
|
@ -129,6 +129,7 @@ module Of_sexp : sig
|
||||||
: 'a t
|
: 'a t
|
||||||
-> ('b, 'c) Constructor_args_spec.t
|
-> ('b, 'c) Constructor_args_spec.t
|
||||||
-> ('a -> 'b, 'c) Constructor_args_spec.t
|
-> ('a -> 'b, 'c) Constructor_args_spec.t
|
||||||
|
val rest : 'a t -> ('a list -> 'b, 'b) Constructor_args_spec.t
|
||||||
|
|
||||||
(** Field that takes multiple values *)
|
(** Field that takes multiple values *)
|
||||||
val field_multi
|
val field_multi
|
||||||
|
@ -147,12 +148,6 @@ module Of_sexp : sig
|
||||||
-> 'b list record_parser
|
-> 'b list record_parser
|
||||||
|
|
||||||
val cstr : string -> ('a, 'b) Constructor_args_spec.t -> 'a -> 'b Constructor_spec.t
|
val cstr : string -> ('a, 'b) Constructor_args_spec.t -> 'a -> 'b Constructor_spec.t
|
||||||
val cstr_rest
|
|
||||||
: string
|
|
||||||
-> ('a, 'b list -> 'c) Constructor_args_spec.t
|
|
||||||
-> 'b t
|
|
||||||
-> 'a
|
|
||||||
-> 'c Constructor_spec.t
|
|
||||||
|
|
||||||
val cstr_record : string -> 'a record_parser -> 'a Constructor_spec.t
|
val cstr_record : string -> 'a record_parser -> 'a Constructor_spec.t
|
||||||
|
|
||||||
|
@ -162,13 +157,6 @@ module Of_sexp : sig
|
||||||
-> (Loc.t -> 'a)
|
-> (Loc.t -> 'a)
|
||||||
-> 'b Constructor_spec.t
|
-> 'b Constructor_spec.t
|
||||||
|
|
||||||
val cstr_rest_loc
|
|
||||||
: string
|
|
||||||
-> ('a, 'b list -> 'c) Constructor_args_spec.t
|
|
||||||
-> 'b t
|
|
||||||
-> (Loc.t -> 'a)
|
|
||||||
-> 'c Constructor_spec.t
|
|
||||||
|
|
||||||
val sum
|
val sum
|
||||||
: 'a Constructor_spec.t list
|
: 'a Constructor_spec.t list
|
||||||
-> 'a t
|
-> 'a t
|
||||||
|
|
Loading…
Reference in New Issue