From a37a495bcab6938cb3eb6645b164b441c5a0067a Mon Sep 17 00:00:00 2001 From: Romain Date: Wed, 14 May 2025 15:20:13 +0200 Subject: [PATCH 1/3] add TSL expressions for memory and duration --- CHANGES.md | 3 ++ lib_core/TSL.ml | 68 +++++++++++++++++++++++++++++--- lib_core/TSL.mli | 8 +++- lib_core/TSL_AST.ml | 11 ++++++ lib_core/TSL_lexer.mll | 4 ++ lib_core/TSL_parser.mly | 81 +++++++++++++++++++++++++++++++++----- lib_core/cli.ml | 2 + lib_core/test.ml | 38 +++++++++++++++--- test/common/test_tsl.ml | 87 ++++++++++++++++++++++++++++++++++++++--- 9 files changed, 277 insertions(+), 25 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 3aab5e20..ac65c636 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -29,6 +29,9 @@ - Added `--junit-mem-peak`. It allows to specify the name of the JUnit property where to store peak memory usage. +- Added TSL predicates that allow to select tests depending on their peak memory usage + and average duration from previous records. + ### Breaking Changes - Tezt is no longer available for OCaml versions earlier than 4.13. diff --git a/lib_core/TSL.ml b/lib_core/TSL.ml index 04e6ef70..51b4a60e 100644 --- a/lib_core/TSL.ml +++ b/lib_core/TSL.ml @@ -22,6 +22,19 @@ let show_string_var : TSL_AST.string_var -> string = function | File -> "file" | Title -> "title" +let show_int_var : TSL_AST.int_var -> string = function Memory -> "memory" + +let show_float_var : TSL_AST.float_var -> string = function + | Duration -> "duration" + +let show_numeric_operator : TSL_AST.numeric_operator -> string = function + | EQ -> "=" + | NE -> "<>" + | GT -> ">" + | GE -> ">=" + | LT -> "<" + | LE -> "<=" + (* The list of safe characters should match the rule in [TSL_lexer]. *) let char_is_unsafe = function | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '-' | '/' | '.' -> false @@ -81,7 +94,7 @@ let add_parentheses s = "(" ^ s ^ ")" let show ?(always_parenthesize = false) expression = let rec show context (expression : TSL_AST.t) = - let parentheses_for_string_predicate = + let parentheses_for_predicate = if always_parenthesize then add_parentheses else match context with @@ -92,11 +105,19 @@ let show ?(always_parenthesize = false) expression = | True -> "true" | False -> "false" | String_predicate (var, Is value) -> - parentheses_for_string_predicate + parentheses_for_predicate (show_string_var var ^ " = " ^ show_string value) | String_predicate (var, Matches value) -> - parentheses_for_string_predicate + parentheses_for_predicate (show_string_var var ^ " =~ " ^ show_string (show_rex value)) + | Int_predicate (var, op, value) -> + parentheses_for_predicate + (show_int_var var ^ " " ^ show_numeric_operator op ^ " " + ^ show_string (string_of_int value)) + | Float_predicate (var, op, value) -> + parentheses_for_predicate + (show_float_var var ^ " " ^ show_numeric_operator op ^ " " + ^ show_string (string_of_float value)) | Has_tag tag -> show_string tag | Not (Has_tag tag) -> if is_valid_tag tag then "/" ^ tag else "not " ^ show_string tag @@ -122,22 +143,56 @@ let show ?(always_parenthesize = false) expression = in show SC_toplevel expression -type env = {file : string; title : string; tags : string list} +(* We want to guarantee that, for a given [x], + the set of all tests is equal to the disjoint union of: + - the set of tests such that [memory >= x]; + - the set of tests such that [memory < x]. + If [memory] could be [None], we could be tempted to have [None <= 1000] be false, + and [None > 1000] be also false at the same time. + So some tests would be in neither subset. *) +type env = { + file : string; + title : string; + tags : string list; + memory : int; + duration : float; +} let get_string : env -> TSL_AST.string_var -> string = fun env -> function File -> env.file | Title -> env.title +let get_int : env -> TSL_AST.int_var -> int = + fun env -> function Memory -> env.memory + +let get_float : env -> TSL_AST.float_var -> float = + fun env -> function Duration -> env.duration + let apply_string_operator : string -> TSL_AST.string_operator -> bool = fun value -> function | Is expected -> String.equal value expected | Matches rex -> value =~ rex +let apply_numeric_operator (type a) (compare : a -> a -> int) (value1 : a) + (operator : TSL_AST.numeric_operator) (value2 : a) : bool = + let c = compare value1 value2 in + match operator with + | EQ -> c = 0 + | NE -> c <> 0 + | GT -> c > 0 + | GE -> c >= 0 + | LT -> c < 0 + | LE -> c <= 0 + let rec eval : env -> TSL_AST.t -> bool = fun env -> function | True -> true | False -> false | String_predicate (var, operator) -> apply_string_operator (get_string env var) operator + | Int_predicate (var, operator, value) -> + apply_numeric_operator Int.compare (get_int env var) operator value + | Float_predicate (var, operator, value) -> + apply_numeric_operator Float.compare (get_float env var) operator value | Has_tag tag -> List.mem tag env.tags | Not p -> not (eval env p) | And (a, b) -> eval env a && eval env b @@ -149,7 +204,10 @@ let conjunction = function let tags expression = let rec gather acc : TSL_AST.t -> _ = function - | True | False | String_predicate ((File | Title), _) -> acc + | True | False + | String_predicate ((File | Title), _) + | Int_predicate _ | Float_predicate _ -> + acc | Has_tag tag -> String_set.add tag acc | Not p -> gather acc p | And (a, b) | Or (a, b) -> gather (gather acc a) b diff --git a/lib_core/TSL.mli b/lib_core/TSL.mli index aa6dd461..43f3ddd3 100644 --- a/lib_core/TSL.mli +++ b/lib_core/TSL.mli @@ -14,7 +14,13 @@ val parse : string -> TSL_AST.t option val show : ?always_parenthesize:bool -> TSL_AST.t -> string (** Environment in which to evaluate TSL expressions. *) -type env = {file : string; title : string; tags : string list} +type env = { + file : string; + title : string; + tags : string list; + memory : int; + duration : float; +} (** Evaluate a TSL expression. *) val eval : env -> TSL_AST.t -> bool diff --git a/lib_core/TSL_AST.ml b/lib_core/TSL_AST.ml index daca2a07..d15facc4 100644 --- a/lib_core/TSL_AST.ml +++ b/lib_core/TSL_AST.ml @@ -12,14 +12,25 @@ open Base (** Test properties that can be queried using string operators. *) type string_var = File | Title +(** Test properties that can be queried using integer comparison operators. *) +type int_var = Memory + +(** Test properties that can be queried using float comparison operators. *) +type float_var = Duration + (** Comparison operators for strings. *) type string_operator = Is of string | Matches of rex +(** Comparison operators for numbers. *) +type numeric_operator = EQ | NE | GT | GE | LT | LE + (** AST of TSL. *) type t = | True | False | String_predicate of string_var * string_operator + | Int_predicate of int_var * numeric_operator * int + | Float_predicate of float_var * numeric_operator * float | Has_tag of string | Not of t | And of t * t diff --git a/lib_core/TSL_lexer.mll b/lib_core/TSL_lexer.mll index 6d3d85e8..8e7622ab 100644 --- a/lib_core/TSL_lexer.mll +++ b/lib_core/TSL_lexer.mll @@ -39,6 +39,10 @@ rule token = parse | '"' { STRING (string (Buffer.create 128) lexbuf) } | '=' { EQUAL } | "<>" { NOT_EQUAL } + | '>' { GREATER } + | ">=" { GREATER_OR_EQUAL } + | '<' { LESS } + | "<=" { LESS_OR_EQUAL } | "=~" { MATCHES } | "=~!" { NOT_MATCHES } | '(' { LPAR } diff --git a/lib_core/TSL_parser.mly b/lib_core/TSL_parser.mly index 6b522909..fb5df2fb 100644 --- a/lib_core/TSL_parser.mly +++ b/lib_core/TSL_parser.mly @@ -16,15 +16,70 @@ let rex s = with Re.Perl.Parse_error -> failwith ("invalid regular expression: " ^ s) -let string_var = function - | "file" -> File - | "title" -> Title - | var -> failwith ("unknown value: " ^ var) +type operator = EQ | NE | GT | GE | LT | LE | Matches | Not_matches + +let show_operator = function + | EQ -> "=" + | NE -> "<>" + | GT -> ">" + | GE -> ">=" + | LT -> "<" + | LE -> "<=" + | Matches -> "=~" + | Not_matches -> "=~!" + +let string_predicate var operator value = + match operator with + | EQ -> String_predicate (var, Is value) + | NE -> Not (String_predicate (var, Is value)) + | Matches -> String_predicate (var, Matches (rex value)) + | Not_matches -> Not (String_predicate (var, Matches (rex value))) + | GT | GE | LT | LE -> failwith ("not a string operator: " ^ show_operator operator) + +let int_predicate var operator value = + let value = + match int_of_string_opt value with + | None -> failwith ("invalid integer: " ^ String.escaped value) + | Some int -> int + in + match operator with + | EQ -> Int_predicate (var, EQ, value) + | NE -> Int_predicate (var, NE, value) + | GT -> Int_predicate (var, GT, value) + | GE -> Int_predicate (var, GE, value) + | LT -> Int_predicate (var, LT, value) + | LE -> Int_predicate (var, LE, value) + | Matches | Not_matches -> failwith ("not an integer operator: " ^ show_operator operator) + +let float_predicate var operator value = + let value = + match float_of_string_opt value with + | None -> failwith ("invalid number: " ^ String.escaped value) + | Some float -> float + in + match operator with + | EQ -> Float_predicate (var, EQ, value) + | NE -> Float_predicate (var, NE, value) + | GT -> Float_predicate (var, GT, value) + | GE -> Float_predicate (var, GE, value) + | LT -> Float_predicate (var, LT, value) + | LE -> Float_predicate (var, LE, value) + | Matches | Not_matches -> failwith ("not a number operator: " ^ show_operator operator) + +let operator var = + match var with + | "file" -> string_predicate File + | "title" -> string_predicate Title + | "memory" -> int_predicate Memory + | "duration" -> float_predicate Duration + | var -> failwith ("unknown value: " ^ var) %} %token STRING SLASH_STRING -%token TRUE FALSE EQUAL NOT_EQUAL MATCHES NOT_MATCHES LPAR RPAR NOT OR AND EOF +%token TRUE FALSE +%token EQUAL NOT_EQUAL GREATER GREATER_OR_EQUAL LESS LESS_OR_EQUAL MATCHES NOT_MATCHES +%token LPAR RPAR NOT OR AND EOF %left OR %left AND @@ -57,12 +112,20 @@ expr: | SLASH_STRING { Not (Has_tag $1) } | STRING EQUAL STRING - { String_predicate (string_var $1, Is $3) } + { operator $1 EQ $3 } | STRING NOT_EQUAL STRING - { Not (String_predicate (string_var $1, Is $3)) } + { operator $1 NE $3 } +| STRING GREATER STRING + { operator $1 GT $3 } +| STRING GREATER_OR_EQUAL STRING + { operator $1 GE $3 } +| STRING LESS STRING + { operator $1 LT $3 } +| STRING LESS_OR_EQUAL STRING + { operator $1 LE $3 } | STRING MATCHES STRING - { String_predicate (string_var $1, Matches (rex $3)) } + { operator $1 Matches $3 } | STRING NOT_MATCHES STRING - { Not (String_predicate (string_var $1, Matches (rex $3))) } + { operator $1 Not_matches $3 } | LPAR expr RPAR { $2 } diff --git a/lib_core/cli.ml b/lib_core/cli.ml index 82f887eb..527dd32a 100644 --- a/lib_core/cli.ml +++ b/lib_core/cli.ml @@ -759,6 +759,8 @@ let _ = - 'file =~! STRING': same as 'not (file =~ STRING)';\n\ - 'title =~ STRING': test title matches the regular expression STRING;\n\ - 'title =~! STRING': same as 'not (title =~ STRING)';\n\ + - 'VAR OPERATOR VALUE' where VAR is 'memory' or 'duration', OPERATOR \ + is one of: = <> > >= < <= and VALUE is a number;\n\ - '(EXPR)': same as EXPR.\n\n\ 'not' has higher precedence than '&&' which has higher precedence than \ '||'.\n\n\ diff --git a/lib_core/test.ml b/lib_core/test.ml index d570b0dc..d02f1ee1 100644 --- a/lib_core/test.ml +++ b/lib_core/test.ml @@ -503,10 +503,11 @@ let files_not_to_run_tree = (* This function uses command-line arguments even though [Clap.close] has not been called yet, but all those arguments are lists of arguments for which the parsing function cannot fail, so we won't get a dummy value. *) -let test_should_be_run ~file ~title ~tags ~cli_tsl_expression = +let test_should_be_run ~file ~title ~tags ~memory ~duration ~cli_tsl_expression + = let uid = file ^ ": " ^ title in let match_uid pattern = uid =~ pattern in - TSL.eval {file; title; tags} cli_tsl_expression + TSL.eval {file; title; tags; memory; duration} cli_tsl_expression && (match Cli.Selecting_tests.tests_to_run with | [] -> true | titles -> List.mem title titles) @@ -986,9 +987,36 @@ let select_tests ~cli_tsl_expression = (* Reset the list of tests to run to re-fill it with the requested job. *) registered := String_map.empty ; String_map.iter - (fun _ ({file; title; tags; _} as test : test) -> - if test_should_be_run ~file ~title ~tags ~cli_tsl_expression then - registered := String_map.add title test !registered) + (fun _ + ({ + file; + title; + tags; + past_records_successful_runs; + past_records_peak_memory_usage; + _; + } as test : + test) + -> + let memory = past_records_peak_memory_usage |> Option.value ~default:0 in + let duration = + let count = Summed_durations.count past_records_successful_runs in + if count > 0 then + let total = + Summed_durations.total_seconds past_records_successful_runs + in + total /. float count + else 0. + in + if + test_should_be_run + ~file + ~title + ~tags + ~memory + ~duration + ~cli_tsl_expression + then registered := String_map.add title test !registered) all_tests (* Apply --job: take the list of registered tests, split it into jobs, diff --git a/test/common/test_tsl.ml b/test/common/test_tsl.ml index 1203ee28..99afc13b 100644 --- a/test/common/test_tsl.ml +++ b/test/common/test_tsl.ml @@ -41,6 +41,18 @@ let () = check "hello" (Has_tag "hello") ; check "\"hello\"" (Has_tag "hello") ; check "\"he\\\\l\\\"lo\"" (Has_tag "he\\l\"lo") ; + check "memory = 100" (Int_predicate (Memory, EQ, 100)) ; + check "memory > 1" (Int_predicate (Memory, GT, 1)) ; + check "memory >= 1" (Int_predicate (Memory, GE, 1)) ; + check "memory <> 100" (Int_predicate (Memory, NE, 100)) ; + check "memory < 1" (Int_predicate (Memory, LT, 1)) ; + check "memory <= 1" (Int_predicate (Memory, LE, 1)) ; + check "duration = 2" (Float_predicate (Duration, EQ, 2.)) ; + check "duration > 1.1" (Float_predicate (Duration, GT, 1.1)) ; + check "duration >= 1.1" (Float_predicate (Duration, GE, 1.1)) ; + check "duration <> 2.2" (Float_predicate (Duration, NE, 2.2)) ; + check "duration < 1.1" (Float_predicate (Duration, LT, 1.1)) ; + check "duration <= 1.1" (Float_predicate (Duration, LE, 1.1)) ; (* Operator: negation. *) check "not true" (Not True) ; check "not false" (Not False) ; @@ -131,9 +143,21 @@ let () = check "file =~ \"[abc]+$\"" ; check "tag" ; check "\"string with \\\\ symbols \\\" in it\"" ; + check "memory = 17" ; + check "memory <> 17" ; + check "memory > 18" ; + check "memory >= 18" ; + check "memory < 19" ; + check "memory <= 19" ; (* Operator: negation. *) check "not (file = f.ml)" ; check "not (title =~ f.ml)" ; + check "not (memory = 17)" ; + check "not (memory <> 17)" ; + check "not (memory > 18)" ; + check "not (memory >= 18)" ; + check "not (memory < 19)" ; + check "not (memory <= 19)" ; check "/tag" ; (* Operators: conjunction and disjunction. *) check "true && false" ; @@ -153,7 +177,13 @@ let () = Test.register ~__FILE__ ~title:"TSL: evaluation" ~tags:["tsl"; "evaluation"] @@ fun () -> let env : TSL.env = - {file = "/some/file.ml"; title = "some title"; tags = ["some"; "tags"]} + { + file = "/some/file.ml"; + title = "some title"; + tags = ["some"; "tags"]; + memory = 100; + duration = 2.; + } in let check string expected = let tsl = parse string in @@ -175,6 +205,42 @@ let () = check "some" true ; check "tags" true ; check "nope" false ; + check "memory = 101" false ; + check "memory = 100" true ; + check "memory = 99" false ; + check "memory <> 101" true ; + check "memory <> 100" false ; + check "memory <> 99" true ; + check "memory >= 101" false ; + check "memory >= 100" true ; + check "memory >= 99" true ; + check "memory > 101" false ; + check "memory > 100" false ; + check "memory > 99" true ; + check "memory <= 101" true ; + check "memory <= 100" true ; + check "memory <= 99" false ; + check "memory < 101" true ; + check "memory < 100" false ; + check "memory < 99" false ; + check "duration = 1.9" false ; + check "duration = 2" true ; + check "duration = 2.1" false ; + check "duration <> 1.9" true ; + check "duration <> 2" false ; + check "duration <> 2.1" true ; + check "duration >= 1.9" true ; + check "duration >= 2" true ; + check "duration >= 2.1" false ; + check "duration > 1.9" true ; + check "duration > 2" false ; + check "duration > 2.1" false ; + check "duration <= 1.9" false ; + check "duration <= 2" true ; + check "duration <= 2.1" true ; + check "duration < 1.9" false ; + check "duration < 2" false ; + check "duration < 2.1" true ; (* Operator: negation. *) check "not true" false ; check "not false" true ; @@ -222,8 +288,11 @@ let () = String.init (Random.int 10) (fun _ -> Char.chr (Random.int 256)) else String.init (Random.int 200) (fun _ -> Char.chr (Random.int 256)) in + let random_numeric_operator () : TSL_AST.numeric_operator = + match Random.int 3 with 0 -> EQ | 1 -> GT | _ -> GE + in let rec random depth : TSL_AST.t = - match Random.int (if depth > 0 then 7 else 2) with + match Random.int (if depth > 0 then 9 else 2) with | 0 -> True | 1 -> False | 2 -> @@ -231,9 +300,17 @@ let () = ( (if Random.bool () then File else Title), if Random.bool () then Is (random_string ()) else Matches (rex "let's not try to generate random regexps") ) - | 3 -> Has_tag (random_string ()) - | 4 -> Not (random (depth - 1)) - | 5 -> And (random (depth - 1), random (depth - 1)) + | 3 -> + Int_predicate + (Memory, random_numeric_operator (), Random.int 10000 - 5000) + | 4 -> + Float_predicate + ( Duration, + random_numeric_operator (), + float (Random.int 10000 - 5000) /. 1000. ) + | 5 -> Has_tag (random_string ()) + | 6 -> Not (random (depth - 1)) + | 7 -> And (random (depth - 1), random (depth - 1)) | _ -> Or (random (depth - 1), random (depth - 1)) in let tsl = random (Random.int 5) in -- GitLab From 6e48f0963c02addb4aa0dcbffc62d187f2d8a45e Mon Sep 17 00:00:00 2001 From: Romain Date: Wed, 14 May 2025 15:21:18 +0200 Subject: [PATCH 2/3] allow plus sign (+) in bare words This is so that we can put the sign in front of number litterals without having to use quotes. --- CHANGES.md | 2 ++ lib_core/TSL.ml | 2 +- lib_core/TSL_lexer.mll | 2 +- lib_core/cli.ml | 2 +- 4 files changed, 5 insertions(+), 3 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index ac65c636..acf5d434 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -32,6 +32,8 @@ - Added TSL predicates that allow to select tests depending on their peak memory usage and average duration from previous records. +- The plus sign `+` no longer needs to be quoted in TSL strings. + ### Breaking Changes - Tezt is no longer available for OCaml versions earlier than 4.13. diff --git a/lib_core/TSL.ml b/lib_core/TSL.ml index 51b4a60e..dc146449 100644 --- a/lib_core/TSL.ml +++ b/lib_core/TSL.ml @@ -37,7 +37,7 @@ let show_numeric_operator : TSL_AST.numeric_operator -> string = function (* The list of safe characters should match the rule in [TSL_lexer]. *) let char_is_unsafe = function - | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '-' | '/' | '.' -> false + | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '-' | '+' | '/' | '.' -> false | _ -> true (* If [true] could be a tag, TSL expressions [true] would select all tests, diff --git a/lib_core/TSL_lexer.mll b/lib_core/TSL_lexer.mll index 8e7622ab..123a6ad6 100644 --- a/lib_core/TSL_lexer.mll +++ b/lib_core/TSL_lexer.mll @@ -29,7 +29,7 @@ - Other than that, it should be as close as possible to OCaml's syntax, including symbols from Base such as "=~". *) -let bare_word_char_except_slash = ['a'-'z' 'A'-'Z' '0'-'9' '_' '-' '.'] +let bare_word_char_except_slash = ['a'-'z' 'A'-'Z' '0'-'9' '_' '+' '-' '.'] let bare_word = bare_word_char_except_slash (bare_word_char_except_slash | '/')* rule token = parse diff --git a/lib_core/cli.ml b/lib_core/cli.ml index 527dd32a..e80b6567 100644 --- a/lib_core/cli.ml +++ b/lib_core/cli.ml @@ -765,7 +765,7 @@ let _ = 'not' has higher precedence than '&&' which has higher precedence than \ '||'.\n\n\ TSL strings need to be quoted using double quotes '\"' unless they \ - only contain characters 'a-zA-Z0-9_-./' and do not start with a slash \ + only contain characters 'a-zA-Z0-9_-+./' and do not start with a slash \ '/'. Double quotes '\"' and backslashes '\\' need to be escaped using \ backslashes '\\'.\n\n\ Note that 'file = STRING' is not equivalent to '--file STRING'. \ -- GitLab From 111853f5df11c7f8d201ef8807587bbfb8a313ba Mon Sep 17 00:00:00 2001 From: Romain Date: Tue, 20 May 2025 10:31:38 +0200 Subject: [PATCH 3/3] select tests after reading records --- lib_core/test.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib_core/test.ml b/lib_core/test.ml index d02f1ee1..71594fe4 100644 --- a/lib_core/test.ml +++ b/lib_core/test.ml @@ -1279,8 +1279,6 @@ let run_with_scheduler scheduler = known_titles Cli.Selecting_tests.tests_not_to_run ; check_existence "tag" known_tags (TSL.tags cli_tsl_expression) ; - (* Select tests. *) - select_tests ~cli_tsl_expression ; (* Read records. *) let records = Fun.flip List.concat_map Cli.Reports.from_records @@ fun path -> @@ -1291,6 +1289,8 @@ let run_with_scheduler scheduler = |> List.map (fun name -> path // name) in List.iter Record.(fun filename -> use_past (input_file filename)) records ; + (* Select tests. *) + select_tests ~cli_tsl_expression ; (* Apply --job if needed. *) select_job () ; (* Apply --skip and --only if needed. *) -- GitLab