diff --git a/src/stdune/sexp.ml b/src/stdune/sexp.ml index f29dbee2..6a918df9 100644 --- a/src/stdune/sexp.ml +++ b/src/stdune/sexp.ml @@ -339,18 +339,26 @@ module Of_sexp = struct module Constructor_args_spec = struct type 'a conv = 'a t 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 + | Nil : ('a, 'a) t + | Rest : 'a conv -> ('a list -> 'b, 'b) t + | Record : 'a record_parser -> ('a -> '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) - | Loc t, sexps -> convert t sexp sexps (f (Ast.loc sexp)) - | Cons (conv, t), s :: sexps -> convert t sexp sexps (f (conv s)) + | Record rp, l -> begin + match sexp with + | Atom (_, A s) | Quoted_string (_, s) -> + of_sexp_errorf sexp "'%s' expect arguments" s + | List (loc, _) -> + f (record rp (List (loc, l))) + end + | Loc t, l -> convert t sexp l (f (Ast.loc sexp)) + | Cons (conv, t), s :: l -> convert t sexp l (f (conv s)) | Cons _, [] -> of_sexp_error sexp "not enough arguments" | Nil, _ :: _ -> of_sexp_error sexp "too many arguments" end @@ -359,6 +367,7 @@ module Of_sexp = struct 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 rest_as_record rp = Constructor_args_spec.Record rp let field_multi name ?default args_spec f state = match find_single state name with @@ -384,32 +393,19 @@ module Of_sexp = struct (res, consume name state) module Constructor_spec = struct - type ('a, 'b) tuple = + type ('a, 'b) unpacked = { name : string ; args : ('a, 'b) Constructor_args_spec.t ; make : 'a } - type 'a record = - { name : string - ; parse : 'a record_parser - } + type 'a t = T : (_, 'a) unpacked -> 'a t [@@unboxed] - type 'a t = - | Tuple : (_, 'a) tuple -> 'a t - | Record : 'a record -> 'a t - - let name = function - | Tuple x -> x.name - | Record x -> x.name + let name (T t) = t.name end module C = Constructor_spec - let cstr name args make = - C.Tuple { name; args; make } - - let cstr_record name parse = - C.Record { name; parse } + let cstr name args make = C.T { name; args; make } let equal_cstr_name a b = Name.compare a b = Eq @@ -422,27 +418,23 @@ module Of_sexp = struct | None -> of_sexp_errorf sexp ~hint:{ on = String.uncapitalize name - ; candidates = List.map cstrs ~f:(fun c -> - String.uncapitalize (C.name c)) + ; candidates = List.map cstrs ~f:C.name } "Unknown constructor %s" name let sum cstrs sexp = match sexp with - | Atom (_, A s) -> begin - match find_cstr cstrs sexp s with - | C.Tuple t -> Constructor_args_spec.convert t.args sexp [] t.make - | C.Record _ -> of_sexp_error sexp "'%s' expect arguments" - end + | Atom (_, A s) -> + let (C.T cstr) = find_cstr cstrs sexp s in + Constructor_args_spec.convert cstr.args sexp [] cstr.make | Quoted_string _ -> of_sexp_error sexp "Atom expected" | List (_, []) -> of_sexp_error sexp "non-empty list expected" - | List (loc, name_sexp :: args) -> + | List (_, name_sexp :: args) -> match name_sexp with | 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 - | C.Record r -> record r.parse (List (loc, args)) + let (C.T cstr) = find_cstr cstrs sexp s in + Constructor_args_spec.convert cstr.args sexp args cstr.make let enum cstrs sexp = match sexp with diff --git a/src/stdune/sexp.mli b/src/stdune/sexp.mli index 8d3bf849..f4f826e5 100644 --- a/src/stdune/sexp.mli +++ b/src/stdune/sexp.mli @@ -133,6 +133,9 @@ module Of_sexp : sig (** Parse all remaining arguments using the following parser *) val rest : 'a t -> ('a list -> 'b, 'b) Constructor_args_spec.t + (** Parse all remaining arguments using the following record parser *) + val rest_as_record : 'a record_parser -> ('a -> 'b, 'b) Constructor_args_spec.t + (** Capture the location of the constructor *) val cstr_loc : ('a, 'b) Constructor_args_spec.t @@ -159,10 +162,6 @@ module Of_sexp : sig -> ('a, 'b) Constructor_args_spec.t -> '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 a42d3c21..734f9545 100644 --- a/src/workspace.ml +++ b/src/workspace.ml @@ -63,10 +63,12 @@ module Context = struct | List (_, List _ :: _) as sexp -> Opam (record (Opam.t ~profile) sexp) | sexp -> sum - [ cstr_record "default" - (Default.t ~profile >>= fun x -> return (Default x)) - ; cstr_record "opam" - (Opam.t ~profile >>= fun x -> return (Opam x)) + [ cstr "default" + (rest_as_record (Default.t ~profile)) + (fun x -> Default x) + ; cstr "opam" + (rest_as_record (Opam.t ~profile)) + (fun x -> Opam x) ] sexp