Only warn for duplicated fields in jbuild files (#976)

Signed-off-by: Jeremie Dimino <jeremie@dimino.org>

src/stanza.ml

@@ -41,4 +41,18 @@ module Of_sexp = struct
       list parse
     else
       repeat parse
+
+  let on_dup parsing_context name entries =
+    match Univ_map.find parsing_context (Syntax.key syntax) with
+    | Some (0, _) ->
+      let last = Option.value_exn (List.last entries) in
+      Loc.warn (Sexp.Ast.loc last)
+        "Field %S is present several times, previous occurrences are ignored."
+        name
+    | _ ->
+      field_present_too_many_times parsing_context name entries
+
+  let field name ?default t = field name ?default t ~on_dup
+  let field_o name t = field_o name t ~on_dup
+  let field_b ?check name = field_b name ?check ~on_dup
 end

src/stanza.mli

@@ -27,10 +27,28 @@ end
 val file_kind : unit -> (File_kind.t, _) Sexp.Of_sexp.parser
 
 (** Overlay for [Sexp.Of_sexp] where lists and records don't require
-    an extra level of parentheses in Dune files. *)
+   an extra level of parentheses in Dune files.
+
+    Additionally, [field_xxx] functions only warn about duplicated
+    fields in jbuild files, for backward compatibility. *)
 module Of_sexp : sig
   include module type of struct include Sexp.Of_sexp end
 
   val record : 'a fields_parser -> 'a t
   val list : 'a t -> 'a list t
+
+  val field
+    :  string
+    -> ?default:'a
+    -> 'a t
+    -> 'a fields_parser
+  val field_o
+    :  string
+    -> 'a t
+    -> 'a option fields_parser
+
+  val field_b
+    :  ?check:(unit t)
+    -> string
+    -> bool fields_parser
 end

src/stdune/sexp.ml

@@ -448,26 +448,33 @@ module Of_sexp = struct
     of_sexp_errorf loc "field %s missing" name
   [@@inline never]
 
-  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 (Ast.loc last.entry) "Field %S is present too many times"
+  let field_present_too_many_times _ name entries =
+    match entries with
+    | _ :: second :: _ ->
+      of_sexp_errorf (Ast.loc second) "Field %S is present too many times"
         name
+    | _ -> assert false
+
+  let multiple_occurrences ?(on_dup=field_present_too_many_times) uc name last =
+    let rec collect acc x =
+      let acc = x.entry :: acc in
+      match x.prev with
+      | None -> acc
+      | Some prev -> collect acc prev
+    in
+    on_dup uc name (collect [] last)
   [@@inline never]
 
-  let find_single state name =
+  let find_single ?on_dup uc 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
+     | Some ({ prev = Some _; _ } as last) ->
+       multiple_occurrences uc name last ?on_dup
      | _ -> ());
     res
 
-  let field name ?default t (Fields (loc, _, uc)) state =
-    match find_single state name with
+  let field name ?default ?on_dup t (Fields (loc, _, uc)) state =
+    match find_single uc state name ?on_dup  with
     | Some { values; entry; _ } ->
       let ctx = Values (Ast.loc entry, Some name, uc) in
       let x = result ctx (t ctx values) in
@@ -477,8 +484,8 @@ module Of_sexp = struct
       | Some v -> (v, add_known name state)
       | None -> field_missing loc name
 
-  let field_o name t (Fields (_, _, uc)) state =
-    match find_single state name with
+  let field_o name ?on_dup t (Fields (_, _, uc)) state =
+    match find_single uc state name ?on_dup with
     | Some { values; entry; _ } ->
       let ctx = Values (Ast.loc entry, Some name, uc) in
       let x = result ctx (t ctx values) in
@@ -486,8 +493,8 @@ module Of_sexp = struct
     | None ->
       (None, add_known name state)
 
-  let field_b ?check name =
-    field name ~default:false
+  let field_b ?check ?on_dup name =
+    field name ~default:false ?on_dup
       (Option.value check ~default:(return ()) >>= fun () ->
         eos >>= function
        | true -> return true

src/stdune/sexp.mli

@@ -212,20 +212,30 @@ module Of_sexp : sig
   val field
     :  string
     -> ?default:'a
+    -> ?on_dup:(Univ_map.t -> string -> Ast.t list -> unit)
     -> 'a t
     -> 'a fields_parser
   val field_o
     :  string
+    -> ?on_dup:(Univ_map.t -> string -> Ast.t list -> unit)
     -> 'a t
     -> 'a option fields_parser
 
-  val field_b : ?check:(unit t) -> string -> bool fields_parser
+  val field_b
+    :  ?check:(unit t)
+    -> ?on_dup:(Univ_map.t -> string -> Ast.t list -> unit)
+    -> string
+    -> bool fields_parser
 
   (** A field that can appear multiple times *)
   val multi_field
     :  string
     -> 'a t
     -> 'a list fields_parser
+
+  (** Default value for [on_dup]. It fails with an appropriate error
+      message. *)
+  val field_present_too_many_times : Univ_map.t -> string -> Ast.t list -> _
 end
 
 module type Sexpable = sig

test/blackbox-tests/dune.inc

@@ -112,6 +112,14 @@
    test-cases/dune-project-edition
    (progn (run %{exe:cram.exe} -test run.t) (diff? run.t run.t.corrected)))))
 
+(alias
+ (name dup-fields)
+ (deps (package dune) (source_tree test-cases/dup-fields))
+ (action
+  (chdir
+   test-cases/dup-fields
+   (progn (run %{exe:cram.exe} -test run.t) (diff? run.t run.t.corrected)))))
+
 (alias
  (name env)
  (deps (package dune) (source_tree test-cases/env))
@@ -668,6 +676,7 @@
   (alias dune-jbuild-var-case)
   (alias dune-ppx-driver-system)
   (alias dune-project-edition)
+  (alias dup-fields)
   (alias env)
   (alias exclude-missing-module)
   (alias exec-cmd)
@@ -748,6 +757,7 @@
   (alias dune-jbuild-var-case)
   (alias dune-ppx-driver-system)
   (alias dune-project-edition)
+  (alias dup-fields)
   (alias env)
   (alias exclude-missing-module)
   (alias exec-cmd)

test/blackbox-tests/test-cases/dup-fields/dune/dune

@@ -0,0 +1,4 @@
+(alias
+ (name default)
+ (action (echo foo))
+ (action (echo bar)))

test/blackbox-tests/test-cases/dup-fields/dune/dune-project

@@ -0,0 +1 @@
+(lang dune 1.0)

test/blackbox-tests/test-cases/dup-fields/jbuild/jbuild

@@ -0,0 +1,4 @@
+(alias
+ ((name default)
+  (action (echo foo))
+  (action (echo bar))))

test/blackbox-tests/test-cases/dup-fields/run.t

@@ -0,0 +1,20 @@
+In dune files
+-------------
+
+Duplicating a field in a dune file is an error:
+
+  $ dune build --root dune
+  File "dune", line 4, characters 1-20:
+  Error: Field "action" is present too many times
+  [1]
+
+In jbuild files
+---------------
+
+For backward compatibility, it is only a warning in jbuild files:
+
+  $ dune build --root jbuild
+  File "jbuild", line 4, characters 2-21:
+  Warning: Field "action" is present several times, previous occurrences are ignored.
+  Entering directory 'jbuild'
+  bar