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,146 @@
 {
+open Import
+
 type 'command block =
   | Command of 'command
   | Comment of string list
-}
 
-let eol = '\n' | eof
+(* Creates location from lexbuf *)
+let loc lexbuf =
+  Loc.create ~start:(Lexing.lexeme_start_p lexbuf) ~stop:(Lexing.lexeme_end_p lexbuf)
+[@@inline]
+
+(* Adjusts the start position by an offset *)
+let adjust_start_cnum offset loc =
+  let start = Loc.start loc in
+  let start = { start with pos_cnum = start.pos_cnum + offset } in
+  Loc.set_start loc start
+[@@inline]
 
-let blank = [' ' '\t' '\r' '\012']
+(* Creates location for "  $ " pattern, adjusting past the "  $ " prefix *)
+let loc_of_dollar lexbuf =
+  loc lexbuf |> adjust_start_cnum 2
+[@@inline]
+
+(* 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 }
+[@@inline]
+
+(* Creates comment from string list accumulator *)
+let create_comment_from_acc loc acc =
+  match acc with
+  | [] -> None
+  | _ -> Some (loc, Comment (List.rev acc))
+[@@inline]
+}
+
+let nonspace = [^' ' '\n']
+let not_nl  = [^'\n']
 
 rule 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)
+    { eol_then_command_or_finish (loc_of_dollar lexbuf) str lexbuf }
+  | "  > " ([^'\n']* as str)
+    { after_comment_line (loc lexbuf) [ "  > " ^ str ] lexbuf }
+  | "  >"
+    { after_comment_line (loc lexbuf) [ "  >" ] lexbuf }
+  | "  " [^'\n']*
+    { after_output_line (loc lexbuf) lexbuf }
+  | ' ' ((nonspace not_nl*) as rest)
+    { after_comment_line (loc lexbuf) [ " " ^ rest ] lexbuf }
+  | ' ' '\n'
+    { let loc = loc lexbuf in
+      let loc = Loc.set_stop loc (pos_before_newline lexbuf) in
+      Lexing.new_line lexbuf;
+      comment loc [ " " ] lexbuf }
+  | ' '
+    { comment (loc lexbuf) [ " " ] lexbuf }
+  | '\n'
+    { let loc = loc lexbuf in
+      let loc = Loc.set_stop loc (Loc.start loc) in
+      Lexing.new_line lexbuf;
+      comment loc [ "" ] lexbuf }
+  | nonspace not_nl* as str
+    { after_comment_line (loc lexbuf) [str] lexbuf }
+
+and after_comment_line loc content = parse
+  | '\n' { Lexing.new_line lexbuf; comment loc content lexbuf }
+  | eof  { comment loc content lexbuf }
+
+and after_output_line loc = parse
+  | '\n' { Lexing.new_line lexbuf; output loc [] lexbuf }
+  | eof  { output loc [] lexbuf }
+
+and eol_then_command_or_finish loc str = parse
+  | '\n' { Lexing.new_line lexbuf; Some (command_cont loc [ str ] lexbuf) }
+  | eof  { Some (loc, Command [ str ]) }
+
+and comment loc 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 loc acc }
+  | ' ' ((nonspace not_nl*) as rest)
+    { let loc = Loc.set_stop loc (Lexing.lexeme_end_p lexbuf) in
+      after_comment_line_in_comment loc (" " ^ rest) acc lexbuf }
+  | ' ' '\n'
+    { let loc = Loc.set_stop loc (pos_before_newline lexbuf) in
+      Lexing.new_line lexbuf;
+      comment loc (" " :: acc) lexbuf }
+  | '\n'
+    { let loc = Loc.set_stop loc (Lexing.lexeme_start_p lexbuf) in
+      Lexing.new_line lexbuf;
+      comment loc ("" :: acc) lexbuf }
+  | nonspace not_nl* as str
+    { let loc = Loc.set_stop loc (Lexing.lexeme_end_p lexbuf) in
+      after_comment_line_in_comment loc str acc lexbuf }
+  | "" { create_comment_from_acc loc acc }
 
-and output maybe_comment = parse
+and after_comment_line_in_comment loc str acc = parse
+  | '\n' { Lexing.new_line lexbuf; comment loc (str :: acc) lexbuf }
+  | eof  { comment loc (str :: acc) lexbuf }
+
+and output loc 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 }
+    { let loc = Loc.set_stop loc (Lexing.lexeme_start_p lexbuf) in
+      create_comment_from_acc loc maybe_comment }
+  | "  $ " ([^'\n']* as str)
+    { eol_then_command_or_finish (loc_of_dollar lexbuf) str lexbuf }
+  | ' ' ((nonspace not_nl*) as rest)
+    { check_eol_for_output loc ((" " ^ rest) :: maybe_comment) lexbuf }
+  | ' ' '\n'
+    { Lexing.new_line lexbuf;
+      output loc (" " :: maybe_comment) lexbuf }
+  | "  " [^'\n']*
+    { after_output_line_in_output loc 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 ->
+        let loc = Loc.set_stop loc (Lexing.lexeme_start_p lexbuf) in
+        comment loc l lexbuf }
+
+and after_output_line_in_output loc maybe_comment = parse
+  | '\n' { Lexing.new_line lexbuf; output loc maybe_comment lexbuf }
+  | eof  { output loc maybe_comment lexbuf }
+
+and check_eol_for_output loc maybe_comment = parse
+  | '\n' { Lexing.new_line lexbuf; output loc maybe_comment lexbuf }
+  | eof  {
+    let loc = Loc.set_stop loc (Lexing.lexeme_start_p lexbuf) in
+    Some (loc, Comment (List.rev maybe_comment)) }
+
+and command_cont loc acc = parse
+  | "  > " ([^'\n']* as str)
+    { let loc = Loc.set_stop loc (Lexing.lexeme_end_p lexbuf) in
+      eol_then_continue_or_finish loc str acc lexbuf }
+  | "  >"
+    { let loc = Loc.set_stop loc (Lexing.lexeme_end_p lexbuf) in
+      eol_then_continue_or_finish loc "" acc lexbuf }
   | ""
-    { Command (List.rev acc)  }
+    { (loc, Command (List.rev acc)) }
+
+and eol_then_continue_or_finish loc content acc = parse
+  | '\n' { Lexing.new_line lexbuf; command_cont loc (content :: acc) lexbuf }
+  | eof  { (loc, Command (List.rev (content :: acc))) }