Skip to content

refactor(cram): track locations inside cram lexer #12335

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Draft
wants to merge 1 commit into
base: main
Choose a base branch
from
Draft

refactor(cram): track locations inside cram lexer #12335

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
39 changes: 21 additions & 18 deletions src/dune_rules/cram/cram_exec.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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 *****"
Expand All @@ -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 *)
Expand All @@ -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);
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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;
Expand Down Expand Up @@ -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
Expand Down
4 changes: 3 additions & 1 deletion src/dune_rules/cram/cram_lexer.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -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
134 changes: 87 additions & 47 deletions src/dune_rules/cram/cram_lexer.mll
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -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) }
Loading
Loading