feature(cram): allow for conflict detection

doc/changes/added/12538.md

@@ -0,0 +1,3 @@
+- Add a `(conflict error|ignore)` option to the cram stanza. When `(conflict
+  error)` is set, the cram test will fail in the presence of conflict markers.
+  (#12538, fixes #12512, @rgrinberg)

doc/reference/dune/cram.rst

@@ -110,3 +110,11 @@ Cram
 
       This limits each selected test to at most 2.5 seconds of execution time.
 
+   .. describe:: (conflict <ignore|error>)
+
+      .. versionadded:: 3.21
+
+      Determines how conflict markers inserted by version control systems are
+      inserted. The default behavior is to ``ignore`` them. Setting ``error``
+      will make the test runner reject such conflicts and refuse to run the
+      test.

src/dune_rules/cram/cram_exec.ml

@@ -40,17 +40,38 @@ let quote_for_sh fn =
     Buffer.contents buf
 ;;
 
-let cram_stanzas lexbuf =
-  let rec loop acc =
-    match Cram_lexer.block lexbuf with
-    | None -> List.rev acc
-    | Some s -> loop (s :: acc)
+let cram_stanzas =
+  let find_conflict state line =
+    match state with
+    | `No_conflict when line = "<<<<<<<" -> `Start
+    | `Start when line = "=======" -> `Split
+    | `Split when line = ">>>>>>>" ->
+      (* CR-someday rgrinberg for alizter: insert a location spanning the
+         entire once we start extracting it *)
+      User_error.raise
+        [ Pp.text "Conflict found. Please remove it or set (conflict allow)" ]
+    | _ -> state
   in
-  loop []
+  fun ~(conflict : Cram_stanza.Conflict.t) lexbuf ->
+    let rec loop acc conflict_state =
+      match Cram_lexer.block lexbuf with
+      | None -> List.rev acc
+      | Some s ->
+        let conflict_state =
+          match s with
+          | Command _ -> conflict_state
+          | Comment lines ->
+            (match conflict with
+             | Ignore -> conflict_state
+             | Error -> List.fold_left lines ~init:conflict_state ~f:find_conflict)
+        in
+        loop (s :: acc) conflict_state
+    in
+    loop [] `No_conflict
 ;;
 
 module For_tests = struct
-  let cram_stanzas = cram_stanzas
+  let cram_stanzas lexbuf = cram_stanzas lexbuf ~conflict:Ignore
 
   let dyn_of_block = function
     | Cram_lexer.Comment lines -> Dyn.variant "Comment" [ Dyn.list Dyn.string lines ]
@@ -455,9 +476,9 @@ let run_cram_test env ~src ~script ~cram_stanzas ~temp_dir ~cwd ~timeout =
       (timeout_msg @ [ timeout_set_message ])
 ;;
 
-let run_produce_correction ~src ~env ~script ~timeout lexbuf =
+let run_produce_correction ~conflict ~src ~env ~script ~timeout lexbuf =
   let temp_dir = make_temp_dir ~script in
-  let cram_stanzas = cram_stanzas lexbuf in
+  let cram_stanzas = cram_stanzas lexbuf ~conflict in
   let cwd = Path.parent_exn script in
   let env = make_run_env env ~temp_dir ~cwd in
   let open Fiber.O in
@@ -474,11 +495,11 @@ module Script = Persistent.Make (struct
     let test_example () = []
   end)
 
-let run_and_produce_output ~src ~env ~dir:cwd ~script ~dst ~timeout =
+let run_and_produce_output ~conflict ~src ~env ~dir:cwd ~script ~dst ~timeout =
   let script_contents = Io.read_file ~binary:false script in
   let lexbuf = Lexbuf.from_string script_contents ~fname:(Path.to_string script) in
   let temp_dir = make_temp_dir ~script in
-  let cram_stanzas = cram_stanzas lexbuf in
+  let cram_stanzas = cram_stanzas lexbuf ~conflict in
   (* We don't want the ".cram.run.t" dir around when executing the script. *)
   Path.rm_rf (Path.parent_exn script);
   let env = make_run_env env ~temp_dir ~cwd in
@@ -524,7 +545,14 @@ module Run = struct
     ;;
 
     let action { src; dir; script; output; timeout } ~ectx:_ ~(eenv : Action.env) =
-      run_and_produce_output ~src ~env:eenv.env ~dir ~script ~dst:output ~timeout
+      run_and_produce_output
+        ~conflict:Ignore
+        ~src
+        ~env:eenv.env
+        ~dir
+        ~script
+        ~dst:output
+        ~timeout
     ;;
   end
 
@@ -537,19 +565,33 @@ let run ~src ~dir ~script ~output ~timeout =
 
 module Make_script = struct
   module Spec = struct
-    type ('path, 'target) t = 'path * 'target
+    type ('path, 'target) t =
+      { script : 'path
+      ; target : 'target
+      ; conflict : Cram_stanza.Conflict.t
+      }
 
     let name = "cram-generate"
-    let version = 1
-    let bimap (src, dst) f g = f src, g dst
+    let version = 2
+    let bimap t f g = { t with script = f t.script; target = g t.target }
     let is_useful_to ~memoize:_ = true
-    let encode (src, dst) path target : Sexp.t = List [ path src; target dst ]
 
-    let action (src, dst) ~ectx:_ ~eenv:_ =
+    let encode { script = src; target = dst; conflict } path target : Sexp.t =
+      List
+        [ path src
+        ; target dst
+        ; Atom
+            (match conflict with
+             | Error -> "error"
+             | Ignore -> "ignore")
+        ]
+    ;;
+
+    let action { script = src; target = dst; conflict } ~ectx:_ ~eenv:_ =
       let commands =
         Io.read_file ~binary:false src
         |> Lexbuf.from_string ~fname:(Path.to_string src)
-        |> cram_stanzas
+        |> cram_stanzas ~conflict
         |> List.filter_map ~f:(function
           | Cram_lexer.Comment _ -> None
           | Command s -> Some s)
@@ -563,7 +605,9 @@ module Make_script = struct
   include Action_ext.Make (Spec)
 end
 
-let make_script ~src ~script = Make_script.action (src, script)
+let make_script ~src ~script ~conflict =
+  Make_script.action { script = src; target = script; conflict }
+;;
 
 module Diff = struct
   module Spec = struct
@@ -589,7 +633,8 @@ module Diff = struct
               [ Pp.textf "%s does not exist or is corrupted" (Path.to_string out) ]
         in
         let current_stanzas =
-          Lexbuf.from_string ~fname:(Path.to_string script) current |> cram_stanzas
+          Lexbuf.from_string ~fname:(Path.to_string script) current
+          |> cram_stanzas ~conflict:Ignore
         in
         let rec loop acc current expected =
           match current with
@@ -630,7 +675,13 @@ module Action = struct
     let action script ~ectx:_ ~(eenv : Action.env) =
       run_expect_test
         script
-        ~f:(run_produce_correction ~src:script ~env:eenv.env ~script ~timeout:None)
+        ~f:
+          (run_produce_correction
+             ~conflict:Ignore
+             ~src:script
+             ~env:eenv.env
+             ~script
+             ~timeout:None)
     ;;
   end
 

src/dune_rules/cram/cram_exec.mli

@@ -1,7 +1,11 @@
 open Import
 
 (** Produces the script containing only the commands to run *)
-val make_script : src:Path.t -> script:Path.Build.t -> Action.t
+val make_script
+  :  src:Path.t
+  -> script:Path.Build.t
+  -> conflict:Cram_stanza.Conflict.t
+  -> Action.t
 
 (** Runs the script created in [make_script] *)
 val run

src/dune_rules/cram/cram_rules.ml

@@ -12,6 +12,7 @@ module Spec = struct
     ; locks : Path.Set.t Action_builder.t
     ; packages : Package.Name.Set.t
     ; timeout : (Loc.t * float) option
+    ; conflict : Cram_stanza.Conflict.t
     }
 
   let make_empty ~test_name_alias =
@@ -24,6 +25,7 @@ module Spec = struct
     ; sandbox = Sandbox_config.needs_sandboxing
     ; packages = Package.Name.Set.empty
     ; timeout = None
+    ; conflict = Ignore
     }
   ;;
 end
@@ -58,6 +60,7 @@ let test_rule
        ; sandbox
        ; packages = _
        ; timeout
+       ; conflict
        } :
         Spec.t)
       (test : (Cram_test.t, error) result)
@@ -107,7 +110,7 @@ let test_rule
        let* () =
          (let open Action_builder.O in
           let+ () = Action_builder.path (Path.build script) in
-          Cram_exec.make_script ~src:(Path.build script) ~script:script_sh
+          Cram_exec.make_script ~src:(Path.build script) ~script:script_sh ~conflict
           |> Action.Full.make)
          |> Action_builder.with_file_targets ~file_targets:[ script_sh ]
          |> Super_context.add_rule sctx ~dir ~loc
@@ -288,6 +291,7 @@ let rules ~sctx ~dir tests =
                   stanza.timeout
                   ~f:(Ordering.min (fun x y -> Float.compare (snd x) (snd y)))
               in
+              let conflict = Option.value ~default:acc.conflict stanza.conflict in
               ( runtest_alias
               , { acc with
                   enabled_if
@@ -298,6 +302,7 @@ let rules ~sctx ~dir tests =
                 ; packages
                 ; sandbox
                 ; timeout
+                ; conflict
                 } ))
       in
       let extra_aliases =

src/dune_rules/cram/cram_stanza.ml

@@ -20,13 +20,28 @@ let decode_applies_to =
   subtree <|> predicate
 ;;
 
+module Conflict = struct
+  type t =
+    | Error
+    | Ignore
+
+  let to_string = function
+    | Error -> "error"
+    | Ignore -> "ignore"
+  ;;
+
+  let all = [ Error; Ignore ]
+  let decode = enum (List.map all ~f:(fun x -> to_string x, x))
+end
+
 type t =
   { loc : Loc.t
   ; applies_to : applies_to
   ; alias : Alias.Name.t option
   ; deps : Dep_conf.t Bindings.t option
   ; enabled_if : Blang.t
   ; locks : Locks.t
+  ; conflict : Conflict.t option
   ; package : Package.t option
   ; runtest_alias : (Loc.t * bool) option
   ; timeout : (Loc.t * float) option
@@ -80,8 +95,22 @@ let decode =
             User_error.raise
               ~loc
               [ Pp.text "Timeout value must be a non-negative float." ])
+     and+ conflict =
+       field_o
+         "conflict"
+         (Dune_lang.Syntax.since Stanza.syntax (3, 21) >>> Conflict.decode)
      in
-     { loc; alias; deps; enabled_if; locks; applies_to; package; runtest_alias; timeout })
+     { loc
+     ; alias
+     ; deps
+     ; enabled_if
+     ; locks
+     ; applies_to
+     ; package
+     ; runtest_alias
+     ; timeout
+     ; conflict
+     })
 ;;
 
 let stanza =

src/dune_rules/cram/cram_stanza.mli

@@ -4,13 +4,22 @@ type applies_to =
   | Whole_subtree
   | Files_matching_in_this_dir of Predicate_lang.Glob.t
 
+module Conflict : sig
+  type t =
+    | Error
+    | Ignore
+
+  val to_string : t -> string
+end
+
 type t =
   { loc : Loc.t (* ; dir : Path.t *)
   ; applies_to : applies_to
   ; alias : Alias.Name.t option
   ; deps : Dep_conf.t Bindings.t option
   ; enabled_if : Blang.t
   ; locks : Locks.t
+  ; conflict : Conflict.t option
   ; package : Package.t option
   ; runtest_alias : (Loc.t * bool) option
   ; timeout : (Loc.t * float) option

test/blackbox-tests/test-cases/cram/conflict-markers.t

@@ -0,0 +1,73 @@
+Cram tests can forbid conflicts:
+
+  $ cat >dune-project <<EOF
+  > (lang dune 3.21)
+  > EOF
+
+  $ cat >dune <<EOF
+  > (cram (conflict error))
+  > EOF
+
+Full conflict without command and output interleaving:
+
+  $ cat >test.t <<EOF
+  > <<<<<<<
+  > A Small
+  > =======
+  > Conflict
+  > >>>>>>>
+  > $ echo tada
+  > EOF
+
+  $ dune runtest test.t
+  Error: Conflict found. Please remove it or set (conflict allow)
+  -> required by _build/default/.cram.test.t/cram.sh
+  -> required by _build/default/.cram.test.t/cram.out
+  -> required by alias test
+  [1]
+
+Full conflict with command and output interleaving:
+
+  $ cat >test.t <<EOF
+  > <<<<<<<
+  >   $ foo
+  > =======
+  >   > bar
+  > >>>>>>>
+  > $ echo tada
+  > EOF
+
+  $ dune runtest test.t
+  Error: Conflict found. Please remove it or set (conflict allow)
+  -> required by _build/default/.cram.test.t/cram.sh
+  -> required by _build/default/.cram.test.t/cram.out
+  -> required by alias test
+  [1]
+
+Partial conflicts are ignored:
+
+  $ cat >test.t <<EOF
+  > <<<<<<<
+  >   $ foo
+  >   > bar
+  > >>>>>>>
+  > EOF
+
+  $ dune runtest test.t
+  File "test.t", line 1, characters 0-0:
+  Error: Files _build/default/test.t and _build/default/test.t.corrected
+  differ.
+  [1]
+
+  $ cat >test.t <<EOF
+  > <<<<<<<
+  >   $ foo
+  > =======
+  >   > bar
+  > EOF
+
+  $ dune runtest test.t
+  File "test.t", line 1, characters 0-0:
+  Error: Files _build/default/test.t and _build/default/test.t.corrected
+  differ.
+  [1]