refactor(cram): lex locations in cram tests

We add support for lexing locations in cram tests.

Signed-off-by: Ali Caglayan <[email protected]>

Author: Alizter

src/dune_rules/cram/cram_exec.ml

@@ -63,16 +63,16 @@ let cram_stanzas =
     let rec loop acc conflict_state =
       match Cram_lexer.block lexbuf with
       | None -> List.rev acc
-      | Some s ->
+      | Some (loc, block) ->
         let conflict_state =
-          match s with
+          match block with
           | Command _ -> conflict_state
           | Comment lines ->
             (match conflict_markers with
              | Ignore -> conflict_state
              | Error -> List.fold_left lines ~init:conflict_state ~f:find_conflict)
         in
-        loop (s :: acc) conflict_state
+        loop ((loc, block) :: acc) conflict_state
     in
     loop [] `No_conflict
 ;;
@@ -485,7 +485,7 @@ let run_cram_test env ~src ~script ~cram_stanzas ~temp_dir ~cwd ~timeout =
 
 let run_produce_correction ~conflict_markers ~src ~env ~script ~timeout lexbuf =
   let temp_dir = make_temp_dir ~script in
-  let cram_stanzas = cram_stanzas lexbuf ~conflict_markers in
+  let cram_stanzas = cram_stanzas lexbuf ~conflict_markers |> List.map ~f:snd in
   let cwd = Path.parent_exn script in
   let env = make_run_env env ~temp_dir ~cwd in
   let open Fiber.O in
@@ -506,7 +506,7 @@ let run_and_produce_output ~conflict_markers ~src ~env ~dir:cwd ~script ~dst ~ti
   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 ~conflict_markers in
+  let cram_stanzas = cram_stanzas lexbuf ~conflict_markers |> List.map ~f:snd 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
@@ -599,6 +599,7 @@ module Make_script = struct
         Io.read_file ~binary:false src
         |> Lexbuf.from_string ~fname:(Path.to_string src)
         |> cram_stanzas ~conflict_markers
+        |> List.map ~f:snd
         |> List.filter_map ~f:(function
           | Cram_lexer.Comment _ -> None
           | Command s -> Some s)
@@ -642,6 +643,7 @@ module Diff = struct
         let current_stanzas =
           Lexbuf.from_string ~fname:(Path.to_string script) current
           |> cram_stanzas ~conflict_markers:Ignore
+          |> List.map ~f:snd
         in
         let rec loop acc current expected =
           match current with

src/dune_rules/cram/cram_exec.mli

@@ -23,6 +23,6 @@ val diff : src:Path.t -> output:Path.t -> Action.t
 val action : Path.t -> Action.t
 
 module For_tests : sig
-  val cram_stanzas : Lexing.lexbuf -> string list Cram_lexer.block list
+  val cram_stanzas : Lexing.lexbuf -> (Loc.t * string list Cram_lexer.block) list
   val dyn_of_block : string list Cram_lexer.block -> Dyn.t
 end

src/dune_rules/cram/cram_lexer.mli

@@ -1,8 +1,10 @@
+open Import
+
 (** .t file parser *)
 
 (** A command or comment. Output blocks are skipped *)
 type 'command block =
   | Command of 'command
   | Comment of string list
 
-val block : Lexing.lexbuf -> string list block option
+val block : Lexing.lexbuf -> (Loc.t * string list block) option

src/dune_rules/cram/cram_lexer.mll

@@ -1,67 +1,142 @@
 {
+open Import
+
 type 'command block =
   | Command of 'command
   | Comment of string list
+
+(* Gets position before consuming newline *)
+let pos_before_newline lexbuf =
+  let pos = Lexing.lexeme_end_p lexbuf in
+  { pos with pos_cnum = pos.pos_cnum - 1 }
+
+(* Creates comment from string list accumulator *)
+let create_comment_from_acc ~start ~stop acc =
+  match acc with
+  | [] -> None
+  | _ -> Some (Loc.create ~start ~stop, Comment (List.rev acc))
+
+(* Helper for extracting start/stop positions *)
+let with_span lexbuf f =
+  let start = Lexing.lexeme_start_p lexbuf in
+  let stop = Lexing.lexeme_end_p lexbuf in
+  f ~start ~stop
+
+(* Forward declarations for lexer rules *)
+let eol_fdecl = Fdecl.create Dyn.opaque
+let command_cont_fdecl = Fdecl.create Dyn.opaque
+
+(* Helper for position extraction + eol + recursive call *)
+let with_span_eol lexbuf content next_rule =
+  with_span lexbuf (fun ~start ~stop ->
+    ignore (Fdecl.get eol_fdecl lexbuf);
+    next_rule start stop content lexbuf)
+
+(* Handles command continuation with eol checking *)
+let handle_command_continuation ~start ~content ~acc lexbuf =
+  let stop = Lexing.lexeme_end_p lexbuf in
+  match Fdecl.get eol_fdecl lexbuf with
+  | true  -> Fdecl.get command_cont_fdecl start stop (content :: acc) lexbuf
+  | false -> (Loc.create ~start ~stop, Command (List.rev (content :: acc)))
+
+(* Processes "  $ " command start pattern *)
+let process_command_start str lexbuf =
+  let start =
+    let pos = Lexing.lexeme_start_p lexbuf in
+    { pos with pos_cnum = pos.pos_cnum + 2 }
+  in
+  let stop = Lexing.lexeme_end_p lexbuf in
+  match Fdecl.get eol_fdecl lexbuf with
+  | true  -> Some (Fdecl.get command_cont_fdecl start stop [ str ] lexbuf)
+  | false -> Some (Loc.create ~start ~stop, Command [ str ])
 }
 
-let eol = '\n' | eof
+let nonspace = [^' ' '\n']
+let not_nl  = [^'\n']
 
-let blank = [' ' '\t' '\r' '\012']
+rule eol = parse
+  | '\n' { Lexing.new_line lexbuf; true }
+  | eof  { false }
 
-rule block = parse
+and block = parse
   | eof { None }
-  | "  $ " ([^'\n']* as str) eol
-    { Some (command_cont [str] lexbuf) }
-  | "  " [^'\n']* eol
-    { output [] lexbuf }
-  | ' '? as str eol
-    { comment [str] lexbuf }
-  | ' '? [^' ' '\n'] [^'\n']* as str eol
-    { comment [str] lexbuf }
-
-and comment acc = parse
+  | "  $ " ([^'\n']* as str)
+    { process_command_start str lexbuf }
+  | "  > " ([^'\n']* as str)
+    { with_span_eol lexbuf [ "  > " ^ str ] comment }
+  | "  >"
+    { with_span_eol lexbuf [ "  >" ] comment }
+  | "  " [^'\n']*
+    { with_span_eol lexbuf [] (fun start _ content lexbuf -> output start content lexbuf) }
+  | ' ' ((nonspace not_nl*) as rest)
+    { with_span_eol lexbuf [ " " ^ rest ] comment }
+  | ' ' '\n'
+    { let start = Lexing.lexeme_start_p lexbuf in
+      let stop = pos_before_newline lexbuf in
+      Lexing.new_line lexbuf;
+      comment start stop [ " " ] lexbuf }
+  | ' '
+    { with_span lexbuf (fun ~start ~stop -> comment start stop [ " " ] lexbuf) }
+  | '\n'
+    { let start = Lexing.lexeme_start_p lexbuf in
+      let stop = Lexing.lexeme_start_p lexbuf in
+      Lexing.new_line lexbuf;
+      comment start stop [ "" ] lexbuf }
+  | nonspace not_nl* as str
+    { with_span_eol lexbuf [str] comment }
+
+and comment start last_content_stop acc = parse
   | eof
-    { match acc with
-    | [] -> None
-    | _ -> Some (Comment (List.rev acc))
-    }
-  | ' '? as str eol
-    { comment (str :: acc) lexbuf }
-  | ' '? [^' ' '\n'] [^'\n']* as str eol
-    { comment (str :: acc) lexbuf }
-  | ""
-    { Some (Comment (List.rev acc)) }
+    { create_comment_from_acc ~start ~stop:last_content_stop acc }
+  | ' ' ((nonspace not_nl*) as rest)
+    { with_span_eol lexbuf [(" " ^ rest)] (fun _start stop content lexbuf ->
+        comment start stop (content @ acc) lexbuf) }
+  | ' ' '\n'
+    { let content_stop = pos_before_newline lexbuf in
+      Lexing.new_line lexbuf;
+      comment start content_stop (" " :: acc) lexbuf }
+  | '\n'
+    { let content_stop = Lexing.lexeme_start_p lexbuf in
+      Lexing.new_line lexbuf;
+      comment start content_stop ("" :: acc) lexbuf }
+  | nonspace not_nl* as str
+    { with_span_eol lexbuf [str] (fun _start stop content lexbuf ->
+        comment start stop (content @ acc) lexbuf) }
+  | "" { create_comment_from_acc ~start ~stop:last_content_stop acc }
 
-and output maybe_comment = parse
+
+and output block_start maybe_comment = parse
   | eof
-    { match maybe_comment with
-    | [] -> None
-    | l -> Some (Comment (List.rev l))
-    }
-  | ' ' eof
-    { Some (Comment (List.rev (" " :: maybe_comment))) }
-  | "  "? eof
-    { None }
-  | "  " eol
-    { output [] lexbuf }
-  | ' '? as s eol
-    { output (s :: maybe_comment) lexbuf }
-  | "  $" eol
-    { output [] lexbuf }
-  | "  " '$' [^' ' '\n'] [^'\n']* eol
-    { output [] lexbuf }
-  | "  " [^'$' '\n'] [^'\n']* eol
-    { output [] lexbuf }
+    { create_comment_from_acc ~start:block_start ~stop:(Lexing.lexeme_start_p lexbuf) maybe_comment }
+  | "  $ " ([^'\n']* as str)
+    { process_command_start str lexbuf }
+  | ' ' ((nonspace not_nl*) as rest)
+    { match eol lexbuf with
+      | true  -> output block_start ((" " ^ rest) :: maybe_comment) lexbuf
+      | false ->
+        Some (Loc.create ~start:block_start ~stop:(Lexing.lexeme_start_p lexbuf)
+             , Comment (List.rev ((" " ^ rest) :: maybe_comment))) }
+  | ' ' '\n'
+    { Lexing.new_line lexbuf;
+      output block_start (" " :: maybe_comment) lexbuf }
+  | "  " [^'\n']*
+    { with_span_eol lexbuf [] (fun _start _stop _content lexbuf ->
+        output block_start maybe_comment lexbuf) }
   | ""
     { match maybe_comment with
-    | [] -> block lexbuf
-    | l -> comment l lexbuf
-    }
-
-and command_cont acc = parse
-  | "  > " ([^'\n']* as str) eol
-    { command_cont (str :: acc) lexbuf }
-  | "  >" eol
-    { command_cont ("" :: acc) lexbuf }
+      | [] -> block lexbuf
+      | l -> comment block_start (Lexing.lexeme_start_p lexbuf) l lexbuf }
+
+and command_cont start last_stop acc = parse
+  | "  > " ([^'\n']* as str)
+    { handle_command_continuation ~start ~content:str ~acc lexbuf }
+  | "  >"
+    { handle_command_continuation ~start ~content:"" ~acc lexbuf }
   | ""
-    { Command (List.rev acc)  }
+    { (Loc.create ~start ~stop:last_stop, Command (List.rev acc)) }
+
+{
+let () =
+  Fdecl.set eol_fdecl eol;
+  Fdecl.set command_cont_fdecl command_cont
+}