Refactor dune-project parsing

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 =
+  field_multi "lang" (name @> version @> nil) (fun () v -> v)
-    enum
-      [ ("dune", ()) ]
-  in
-  sum
-    [ cstr "lang" (name @> version @> nil) (fun () v -> v) ]
 
-module Acc = struct
+let name ~dir =
-  type t =
+  field_o "name" string >>= function
-    { name : string option
+  | Some s -> return s
-    }
+  | None -> return ("_" ^ String.concat ~sep:"_" (Path.explode_exn dir))
 
-  let init =
+let parse ~dir =
-    { name = None }
+  record
-end
+    (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 sexp = Io.Sexp.load_many_as_one fname in
-  let langs, sexps =
+  parse ~dir sexp
-    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)
-  }

src/stdune/sexp.ml

@@ -140,8 +140,8 @@ module Of_sexp = struct
     tbl
 
   type unparsed_field =
-    { value : Ast.t option
+    { values : Ast.t list
-    ; entry : Ast.t
+    ; 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 ->
+      | None -> field_missing state name
-        of_sexp_errorf_loc state.loc "field %s missing" 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)]) ->
+          | List (_, name_sexp :: values) -> begin
-            Name_map.add acc name { value = None; entry = sexp }
-          | List (_, [name_sexp; value]) -> 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 (<name> <values>...) 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

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