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

@@ -54,7 +54,8 @@ module For_tests = struct
 
   let dyn_of_block = function
     | Cram_lexer.Comment lines -> Dyn.variant "Comment" [ Dyn.list Dyn.string lines ]
-    | Command lines -> Dyn.variant "Command" [ Dyn.list Dyn.string lines ]
+    | Command (loc, lines) ->
+      Dyn.variant "Command" [ Loc.to_dyn loc; Dyn.list Dyn.string lines ]
   ;;
 end
 
@@ -178,10 +179,10 @@ let read_and_attach_exit_codes (sh_script : sh_script)
     | [], [] -> List.rev acc
     | (Cram_lexer.Comment _ as comment) :: blocks, _ ->
       loop (comment :: acc) entries blocks
-    | Command block_result :: blocks, metadata_entry :: entries ->
-      loop (Command (block_result, Present metadata_entry) :: acc) entries blocks
-    | Cram_lexer.Command block_result :: blocks, [] ->
-      loop (Command (block_result, Missing_unreachable) :: acc) entries blocks
+    | Command (loc, block_result) :: blocks, metadata_entry :: entries ->
+      loop (Command (loc, (block_result, Present metadata_entry)) :: acc) entries blocks
+    | Cram_lexer.Command (loc, block_result) :: blocks, [] ->
+      loop (Command (loc, (block_result, Missing_unreachable)) :: acc) entries blocks
     | [], _ :: _ -> Code_error.raise "more blocks than metadata" []
   in
   loop [] metadata_entries sh_script.cram_to_output
@@ -238,7 +239,7 @@ let sanitize ~parent_script cram_to_output : command_out Cram_lexer.block list =
   List.map cram_to_output ~f:(fun (t : (block_result * _) Cram_lexer.block) ->
     match t with
     | Cram_lexer.Comment t -> Cram_lexer.Comment t
-    | Command (block_result, metadata) ->
+    | Command (loc, (block_result, metadata)) ->
       let output =
         match metadata with
         | Missing_unreachable -> "***** UNREACHABLE *****"
@@ -250,7 +251,7 @@ let sanitize ~parent_script cram_to_output : command_out Cram_lexer.block list =
                ~command_script:block_result.script
                build_path_prefix_map
       in
-      Command { command = block_result.command; metadata; output })
+      Command (loc, { command = block_result.command; metadata; output }))
 ;;
 
 (* Compose user written cram stanzas to output *)
@@ -267,7 +268,7 @@ let compose_cram_output (cram_to_output : _ Cram_lexer.block list) =
   List.iter cram_to_output ~f:(fun block ->
     match (block : _ Cram_lexer.block) with
     | Comment lines -> List.iter lines ~f:add_line
-    | Command { command; metadata; output } ->
+    | Command (_loc, { command; metadata; output }) ->
       List.iteri command ~f:(fun i line ->
         let line = sprintf "%c %s" (if i = 0 then '$' else '>') line in
         add_line_prefixed_with_two_space line);
@@ -314,7 +315,7 @@ let create_sh_script cram_stanzas ~temp_dir : sh_script Fiber.t =
   let loop block =
     match (block : _ Cram_lexer.block) with
     | Comment _ as comment -> Fiber.return comment
-    | Command lines ->
+    | Command (loc, lines) ->
       incr i;
       let i = !i in
       let file ~ext = file (sprintf "%d%s" i ext) in
@@ -340,10 +341,11 @@ let create_sh_script cram_stanzas ~temp_dir : sh_script Fiber.t =
         Dune_util.Build_path_prefix_map._BUILD_PATH_PREFIX_MAP
         metadata_file_sh_path;
       Cram_lexer.Command
-        { command = lines
-        ; output_file = user_shell_code_output_file
-        ; script = user_shell_code_file
-        }
+        ( loc
+        , { command = lines
+          ; output_file = user_shell_code_output_file
+          ; script = user_shell_code_file
+          } )
   in
   fprln oc "trap 'exit 0' EXIT";
   let+ cram_to_output = Fiber.sequential_map ~f:loop cram_stanzas in
@@ -433,7 +435,7 @@ let run_cram_test env ~src ~script ~cram_stanzas ~temp_dir ~cwd ~timeout =
         let command_blocks_only =
           List.filter_map sh_script.cram_to_output ~f:(function
             | Cram_lexer.Comment _ -> None
-            | Cram_lexer.Command block_result -> Some block_result)
+            | Cram_lexer.Command (_, block_result) -> Some block_result)
         in
         let total_commands = List.length command_blocks_only in
         if completed_count < total_commands
@@ -486,7 +488,7 @@ let run_and_produce_output ~src ~env ~dir:cwd ~script ~dst ~timeout =
   let+ commands =
     run_cram_test env ~src ~script ~cram_stanzas ~temp_dir ~cwd ~timeout
     >>| List.filter_map ~f:(function
-      | Cram_lexer.Command c -> Some c
+      | Cram_lexer.Command (_, c) -> Some c
       | Comment _ -> None)
   in
   let dst = Path.build dst in
@@ -552,7 +554,7 @@ module Make_script = struct
         |> cram_stanzas
         |> List.filter_map ~f:(function
           | Cram_lexer.Comment _ -> None
-          | Command s -> Some s)
+          | Command (_, s) -> Some s)
         |> cram_commmands
       in
       Io.write_file ~binary:false (Path.build dst) commands;
@@ -596,10 +598,11 @@ module Diff = struct
           | [] -> acc
           | Cram_lexer.Comment x :: current ->
             loop (Cram_lexer.Comment x :: acc) current expected
-          | Command _ :: current ->
+          | Command (loc, _) :: current ->
             (match expected with
              | [] -> acc
-             | out :: expected -> loop (Cram_lexer.Command out :: acc) current expected)
+             | out :: expected ->
+               loop (Cram_lexer.Command (loc, out) :: acc) current expected)
         in
         loop [] current_stanzas out |> List.rev
       in

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
+  | Command of Loc.t * 'command
   | Comment of string list
 
 val block : Lexing.lexbuf -> string list block option

src/dune_rules/cram/cram_lexer.mll

@@ -1,67 +1,107 @@
 {
+open Import
+
 type 'command block =
-  | Command of 'command
+  | Command of Loc.t * 'command
   | Comment of string list
 }
 
-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 }
+  | "  $ " ([^'\n']* as str)
+    { let start = Lexing.lexeme_start_p lexbuf in
+      let start = { start with pos_cnum = start.pos_cnum + 2 } in
+      let stop0 = Lexing.lexeme_end_p lexbuf in
+      match eol lexbuf with
+      | true  -> Some (command_cont start stop0 [ str ] lexbuf)
+      | false -> Some (Command (Loc.create ~start ~stop:stop0, [ str ])) }
+  | "  > " ([^'\n']* as str)
+    { ignore (eol lexbuf);
+      comment [ "  > " ^ str ] lexbuf }
+  | "  >"
+    { ignore (eol lexbuf);
+      comment [ "  >" ] lexbuf }
+  | "  " [^'\n']*
+    { ignore (eol lexbuf);
+      output [] lexbuf }
+  | ' ' ((nonspace not_nl*) as rest)
+    { ignore (eol lexbuf);
+      comment [ " " ^ rest ] lexbuf }
+  | ' ' '\n'
+    { Lexing.new_line lexbuf;
+      comment [ " " ] lexbuf }
+  | ' '
+    { comment [ " " ] lexbuf }
+  | '\n'
+    { Lexing.new_line lexbuf;
+      comment [ "" ] lexbuf }
+  | nonspace not_nl* as str
+    { ignore (eol lexbuf);
+      comment [str] lexbuf }
 
 and comment 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)) }
+      | [] -> None
+      | _ -> Some (Comment (List.rev acc)) }
+  | ' ' ((nonspace not_nl*) as rest)
+    { ignore (eol lexbuf);
+      comment ((" " ^ rest) :: acc) lexbuf }
+  | ' ' '\n'
+    { Lexing.new_line lexbuf;
+      comment (" " :: acc) lexbuf }
+  | '\n'
+    { Lexing.new_line lexbuf;
+      comment ("" :: acc) lexbuf }
+  | nonspace not_nl* as str
+    { ignore (eol lexbuf);
+      comment (str :: acc) lexbuf }
+  | "" { Some (Comment (List.rev acc)) }
 
 and output 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 }
+      | [] -> None
+      | l -> Some (Comment (List.rev l)) }
+  | "  $ " ([^'\n']* as str)
+    { let start = Lexing.lexeme_start_p lexbuf in
+      let start = { start with pos_cnum = start.pos_cnum + 2 } in
+      let stop0 = Lexing.lexeme_end_p lexbuf in
+      match eol lexbuf with
+      | true  -> Some (command_cont start stop0 [ str ] lexbuf)
+      | false -> Some (Command (Loc.create ~start ~stop:stop0, [ str ])) }
+  | ' ' ((nonspace not_nl*) as rest)
+    { match eol lexbuf with
+      | true  -> output ((" " ^ rest) :: maybe_comment) lexbuf
+      | false -> Some (Comment (List.rev ((" " ^ rest) :: maybe_comment))) }
+  | ' ' '\n'
+    { Lexing.new_line lexbuf;
+      output (" " :: maybe_comment) lexbuf }
+  | "  " [^'\n']*
+    { ignore (eol lexbuf);
+      output maybe_comment lexbuf }
   | ""
     { match maybe_comment with
-    | [] -> block lexbuf
-    | l -> comment l lexbuf
-    }
+      | [] -> 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 }
+and command_cont start last_stop acc = parse
+  | "  > " ([^'\n']* as str)
+    { let stop0 = Lexing.lexeme_end_p lexbuf in
+      match eol lexbuf with
+      | true  -> command_cont start stop0 (str :: acc) lexbuf
+      | false -> Command (Loc.create ~start ~stop:stop0, List.rev (str :: acc)) }
+  | "  >"
+    { let stop0 = Lexing.lexeme_end_p lexbuf in
+      match eol lexbuf with
+      | true  -> command_cont start stop0 ("" :: acc) lexbuf
+      | false -> Command (Loc.create ~start ~stop:stop0, List.rev ("" :: acc)) }
   | ""
-    { Command (List.rev acc)  }
+    { Command (Loc.create ~start ~stop:last_stop, List.rev acc) }