Allow fields that can appear multiple times
This commit is contained in:
parent
03b53256b3
commit
cae4948b72
|
@ -142,6 +142,7 @@ module Of_sexp = struct
|
||||||
type unparsed_field =
|
type unparsed_field =
|
||||||
{ values : Ast.t list
|
{ values : Ast.t list
|
||||||
; entry : Ast.t
|
; entry : Ast.t
|
||||||
|
; prev : unparsed_field option (* Previous occurrence of this field *)
|
||||||
}
|
}
|
||||||
|
|
||||||
module Name = struct
|
module Name = struct
|
||||||
|
@ -235,12 +236,29 @@ module Of_sexp = struct
|
||||||
let field_missing state name =
|
let field_missing state name =
|
||||||
of_sexp_errorf_loc state.loc "field %s missing" name
|
of_sexp_errorf_loc state.loc "field %s missing" name
|
||||||
|
|
||||||
|
let rec multiple_occurrences ~name ~last ~prev =
|
||||||
|
match prev.prev with
|
||||||
|
| Some prev_prev ->
|
||||||
|
(* 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
|
||||||
|
[@@inline never]
|
||||||
|
|
||||||
|
let find_single state name =
|
||||||
|
let res = Name_map.find state.unparsed name in
|
||||||
|
(match res with
|
||||||
|
| Some ({ prev = Some prev; _ } as last) ->
|
||||||
|
multiple_occurrences ~name ~last ~prev
|
||||||
|
| _ -> ());
|
||||||
|
res
|
||||||
|
|
||||||
let field name ?(short=Short_syntax.Not_allowed)
|
let field name ?(short=Short_syntax.Not_allowed)
|
||||||
?default value_of_sexp state =
|
?default value_of_sexp state =
|
||||||
match Name_map.find state.unparsed name with
|
match find_single state name with
|
||||||
| Some { values = [value]; _ } ->
|
| Some { values = [value]; _ } ->
|
||||||
(value_of_sexp value, consume name state)
|
(value_of_sexp value, consume name state)
|
||||||
| Some { values = []; entry } ->
|
| Some { values = []; entry; _ } ->
|
||||||
(Short_syntax.parse short entry name,
|
(Short_syntax.parse short entry name,
|
||||||
consume name state)
|
consume name state)
|
||||||
| Some f ->
|
| Some f ->
|
||||||
|
@ -251,10 +269,10 @@ module Of_sexp = struct
|
||||||
| None -> field_missing state name
|
| None -> field_missing state name
|
||||||
|
|
||||||
let field_o name ?(short=Short_syntax.Not_allowed) value_of_sexp state =
|
let field_o name ?(short=Short_syntax.Not_allowed) value_of_sexp state =
|
||||||
match Name_map.find state.unparsed name with
|
match find_single state name with
|
||||||
| Some { values = [value]; _ } ->
|
| Some { values = [value]; _ } ->
|
||||||
(Some (value_of_sexp value), consume name state)
|
(Some (value_of_sexp value), consume name state)
|
||||||
| Some { values = []; entry } ->
|
| Some { values = []; entry; _ } ->
|
||||||
(Some (Short_syntax.parse short entry name),
|
(Some (Short_syntax.parse short entry name),
|
||||||
consume name state)
|
consume name state)
|
||||||
| Some f ->
|
| Some f ->
|
||||||
|
@ -263,6 +281,20 @@ module Of_sexp = struct
|
||||||
|
|
||||||
let field_b name = field name bool ~default:false ~short:(This true)
|
let field_b name = field name bool ~default:false ~short:(This true)
|
||||||
|
|
||||||
|
let dup_field name ?(short=Short_syntax.Not_allowed) value_of_sexp state =
|
||||||
|
let rec loop acc field =
|
||||||
|
match field with
|
||||||
|
| None -> acc
|
||||||
|
| Some { values = [value]; prev; _ } ->
|
||||||
|
loop (value_of_sexp value :: acc) prev
|
||||||
|
| Some { values = []; entry; prev } ->
|
||||||
|
loop (Short_syntax.parse short entry name :: acc) prev
|
||||||
|
| Some f ->
|
||||||
|
too_many_values name f
|
||||||
|
in
|
||||||
|
let res = loop [] (Name_map.find state.unparsed name) in
|
||||||
|
(res, consume name state)
|
||||||
|
|
||||||
let make_record_parser_state sexp =
|
let make_record_parser_state sexp =
|
||||||
match sexp with
|
match sexp with
|
||||||
| Atom _ | Quoted_string _ -> of_sexp_error sexp "List expected"
|
| Atom _ | Quoted_string _ -> of_sexp_error sexp "List expected"
|
||||||
|
@ -273,9 +305,11 @@ module Of_sexp = struct
|
||||||
| List (_, name_sexp :: values) -> begin
|
| List (_, name_sexp :: values) -> begin
|
||||||
match name_sexp with
|
match name_sexp with
|
||||||
| Atom (_, A name) ->
|
| Atom (_, A name) ->
|
||||||
if Name_map.mem acc name then
|
Name_map.add acc name
|
||||||
of_sexp_errorf sexp "Field %S is present too many times" name;
|
{ values
|
||||||
Name_map.add acc name { values; entry = sexp }
|
; entry = sexp
|
||||||
|
; prev = Name_map.find acc name
|
||||||
|
}
|
||||||
| List _ | Quoted_string _ ->
|
| List _ | Quoted_string _ ->
|
||||||
of_sexp_error name_sexp "Atom expected"
|
of_sexp_error name_sexp "Atom expected"
|
||||||
end
|
end
|
||||||
|
@ -328,8 +362,8 @@ module Of_sexp = struct
|
||||||
let ( @> ) a b = Constructor_args_spec.Cons (a, b)
|
let ( @> ) a b = Constructor_args_spec.Cons (a, b)
|
||||||
|
|
||||||
let field_multi name ?default args_spec f state =
|
let field_multi name ?default args_spec f state =
|
||||||
match Name_map.find state.unparsed 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 No_rest entry values f,
|
||||||
consume name state)
|
consume name state)
|
||||||
| None ->
|
| None ->
|
||||||
|
@ -337,6 +371,19 @@ module Of_sexp = struct
|
||||||
| Some v -> (v, add_known name state)
|
| Some v -> (v, add_known name state)
|
||||||
| None -> field_missing state name
|
| None -> field_missing state name
|
||||||
|
|
||||||
|
let dup_field_multi name args_spec f state =
|
||||||
|
let rec loop acc field =
|
||||||
|
match field with
|
||||||
|
| None -> acc
|
||||||
|
| Some { values; entry; prev } ->
|
||||||
|
let x =
|
||||||
|
Constructor_args_spec.convert args_spec No_rest entry values f
|
||||||
|
in
|
||||||
|
loop (x :: acc) prev
|
||||||
|
in
|
||||||
|
let res = loop [] (Name_map.find state.unparsed name) in
|
||||||
|
(res, consume name state)
|
||||||
|
|
||||||
module Constructor_spec = struct
|
module Constructor_spec = struct
|
||||||
type ('a, 'b, 'c) tuple =
|
type ('a, 'b, 'c) tuple =
|
||||||
{ name : string
|
{ name : string
|
||||||
|
|
|
@ -100,6 +100,13 @@ module Of_sexp : sig
|
||||||
-> 'a option record_parser
|
-> 'a option record_parser
|
||||||
val field_b : string -> bool record_parser
|
val field_b : string -> bool record_parser
|
||||||
|
|
||||||
|
(** A field that can appear multiple times *)
|
||||||
|
val dup_field
|
||||||
|
: string
|
||||||
|
-> ?short:'a Short_syntax.t
|
||||||
|
-> 'a t
|
||||||
|
-> 'a list record_parser
|
||||||
|
|
||||||
val map_validate
|
val map_validate
|
||||||
: 'a record_parser
|
: 'a record_parser
|
||||||
-> f:('a -> ('b, string) Result.result)
|
-> f:('a -> ('b, string) Result.result)
|
||||||
|
@ -131,6 +138,14 @@ module Of_sexp : sig
|
||||||
-> 'a
|
-> 'a
|
||||||
-> 'b record_parser
|
-> 'b record_parser
|
||||||
|
|
||||||
|
(** A field that can appear multiple times and each time takes
|
||||||
|
multiple values *)
|
||||||
|
val dup_field_multi
|
||||||
|
: string
|
||||||
|
-> ('a, 'b) Constructor_args_spec.t
|
||||||
|
-> 'a
|
||||||
|
-> '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
|
val cstr_rest
|
||||||
: string
|
: string
|
||||||
|
|
|
@ -31,3 +31,10 @@ Exception:
|
||||||
Stdune__Sexp.Of_sexp.Of_sexp (<abstr>,
|
Stdune__Sexp.Of_sexp.Of_sexp (<abstr>,
|
||||||
"Field \"foo\" is present too many times", None).
|
"Field \"foo\" is present too many times", None).
|
||||||
|}]
|
|}]
|
||||||
|
|
||||||
|
let of_sexp = record (dup_field "foo" int)
|
||||||
|
let x = of_sexp sexp
|
||||||
|
[%%expect{|
|
||||||
|
val of_sexp : int list Stdune.Sexp.Of_sexp.t = <fun>
|
||||||
|
val x : int list = [1; 2]
|
||||||
|
|}]
|
||||||
|
|
Loading…
Reference in New Issue