diff --git a/src/dune_project.ml b/src/dune_project.ml index 4baf76ab..30cc2579 100644 --- a/src/dune_project.ml +++ b/src/dune_project.ml @@ -11,59 +11,30 @@ type lang = | Dune_0_1 let lang = + let name = + enum + [ ("dune", ()) ] + in let version ver = match string ver with | "0.1" -> Dune_0_1 | _ -> of_sexp_error ver "unsupported version of the dune language" in - let name = - enum - [ ("dune", ()) ] - in - sum - [ cstr "lang" (name @> version @> nil) (fun () v -> v) ] + field_multi "lang" (name @> version @> nil) (fun () v -> v) -module Acc = struct - type t = - { name : string option - } +let name ~dir = + field_o "name" string >>= function + | Some s -> return s + | None -> return ("_" ^ String.concat ~sep:"_" (Path.explode_exn dir)) - let init = - { name = None } -end +let parse ~dir = + record + (lang >>= fun Dune_0_1 -> + name ~dir >>= fun name -> + return { name }) let load ~dir = let fname = Path.relative dir filename in - let sexps = Io.Sexp.load fname ~mode:Many in - let langs, sexps = - List.partition_map sexps ~f:(function - | List (loc, Atom (_, A "lang") :: _) as sexp -> - Left (lang sexp, loc) - | sexp -> Right sexp) - in - let _lang = - match langs with - | [] -> - Loc.fail (Loc.in_file (Path.to_string fname)) - "language not specified, you need to add (lang dune 0.1)" - | [(v, _)] -> v - | _ :: (_, loc) :: _ -> - Loc.fail loc "language specified too many times" - in - let acc = - List.fold_left sexps ~init:Acc.init ~f:(fun (acc : Acc.t) sexp -> - sum - [ cstr "lang" nil acc - ; cstr_loc "name" (string @> nil) (fun loc name -> - match acc.name with - | None -> { Acc.name = Some name } - | Some _ -> Loc.fail loc "name specified too many times") - ] - sexp) - in - { name = - match acc.name with - | Some s -> s - | None -> "_" ^ String.concat ~sep:"_" (Path.explode_exn dir) - } + let sexp = Io.Sexp.load_many_as_one fname in + parse ~dir sexp diff --git a/src/stdune/sexp.ml b/src/stdune/sexp.ml index 9e6272d9..cac9b1d4 100644 --- a/src/stdune/sexp.ml +++ b/src/stdune/sexp.ml @@ -140,8 +140,8 @@ module Of_sexp = struct tbl type unparsed_field = - { value : Ast.t option - ; entry : Ast.t + { values : Ast.t list + ; entry : Ast.t } module Name = struct @@ -229,27 +229,36 @@ module Of_sexp = struct | Located f -> f (Ast.loc entry) end + let too_many_values name field = + of_sexp_errorf_loc (Ast.loc field.entry) "too many values for field %s" name + + let field_missing state name = + of_sexp_errorf_loc state.loc "field %s missing" name + let field name ?(short=Short_syntax.Not_allowed) ?default value_of_sexp state = match Name_map.find state.unparsed name with - | Some { value = Some value; _ } -> + | Some { values = [value]; _ } -> (value_of_sexp value, consume name state) - | Some { value = None; entry } -> + | Some { values = []; entry } -> (Short_syntax.parse short entry name, consume name state) + | Some f -> + too_many_values name f | None -> match default with | Some v -> (v, add_known name state) - | None -> - of_sexp_errorf_loc state.loc "field %s missing" name + | None -> field_missing state name let field_o name ?(short=Short_syntax.Not_allowed) value_of_sexp state = match Name_map.find state.unparsed name with - | Some { value = Some value; _ } -> + | Some { values = [value]; _ } -> (Some (value_of_sexp value), consume name state) - | Some { value = None; entry } -> + | Some { values = []; entry } -> (Some (Short_syntax.parse short entry name), consume name state) + | Some f -> + too_many_values name f | None -> (None, add_known name state) let field_b name = field name bool ~default:false ~short:(This true) @@ -261,17 +270,16 @@ module Of_sexp = struct let unparsed = List.fold_left sexps ~init:Name_map.empty ~f:(fun acc sexp -> match sexp with - | List (_, [Atom (_, A name)]) -> - Name_map.add acc name { value = None; entry = sexp } - | List (_, [name_sexp; value]) -> begin + | List (_, name_sexp :: values) -> begin match name_sexp with | Atom (_, A name) -> - Name_map.add acc name { value = Some value; entry = sexp } + Name_map.add acc name { values; entry = sexp } | List _ | Quoted_string _ -> of_sexp_error name_sexp "Atom expected" end | _ -> - of_sexp_error sexp "S-expression of the form (_ _) expected") + of_sexp_error sexp + "S-expression of the form ( ...) expected") in { loc = loc ; known = [] @@ -317,6 +325,16 @@ module Of_sexp = struct let nil = Constructor_args_spec.Nil let ( @> ) a b = Constructor_args_spec.Cons (a, b) + let field_multi name ?default args_spec f state = + match Name_map.find state.unparsed name with + | Some { values; entry } -> + (Constructor_args_spec.convert args_spec No_rest entry values f, + consume name state) + | None -> + match default with + | Some v -> (v, add_known name state) + | None -> field_missing state name + module Constructor_spec = struct type ('a, 'b, 'c) tuple = { name : string diff --git a/src/stdune/sexp.mli b/src/stdune/sexp.mli index f289664b..13341b53 100644 --- a/src/stdune/sexp.mli +++ b/src/stdune/sexp.mli @@ -123,6 +123,14 @@ module Of_sexp : sig -> ('b, 'c) Constructor_args_spec.t -> ('a -> 'b, 'c) Constructor_args_spec.t + (** Field that takes multiple values *) + val field_multi + : string + -> ?default:'b + -> ('a, 'b) Constructor_args_spec.t + -> 'a + -> 'b record_parser + val cstr : string -> ('a, 'b) Constructor_args_spec.t -> 'a -> 'b Constructor_spec.t val cstr_rest : string