Source file TSL.ml

(*****************************************************************************)
(*                                                                           *)
(* SPDX-License-Identifier: MIT                                              *)
(* Copyright (c) 2023 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(*****************************************************************************)

open Base

let parse string =
  try
    Some (TSL_parser.expression TSL_lexer.token (Lexing.from_string string))
  with
  | Parsing.Parse_error -> None
  | Failure _ (* can be raised by the code generated by ocamllex or ocamlyacc *)
  | TSL_lexer.Error _ ->
      None

type show_context = SC_not | SC_and | SC_or | SC_toplevel

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
  | _ -> true

(* If [true] could be a tag, TSL expressions [true] would select all tests,
   even though the user may actually have meant to only select tests with tag [true].
   The same applies for [false]. *)
let is_valid_tag = function
  | "true" | "false" -> false
  | tag ->
      let len = String.length tag in
      1 <= len && len <= 32
      &&
      let rec check i =
        if i >= len then true
        else
          match tag.[i] with
          | 'a' .. 'z' | '0' .. '9' | '_' -> check (i + 1)
          | _ -> false
      in
      check 0

(* [String.exists] is only from OCaml 4.13.0. *)
let string_exists f s =
  let exception Yes in
  try
    for i = 0 to String.length s - 1 do
      if f s.[i] then raise Yes
    done ;
    false
  with Yes -> true

let show_string string =
  match string with
  | "" -> "\"\""
  | "not" -> "\"not\""
  | "true" -> "\"true\""
  | "false" -> "\"false\""
  | _ ->
      let needs_quotes =
        string.[0] = '/' || string_exists char_is_unsafe string
      in
      if needs_quotes then (
        let buffer = Buffer.create (String.length string * 2) in
        Buffer.add_char buffer '"' ;
        for i = 0 to String.length string - 1 do
          let c = string.[i] in
          (match c with '"' | '\\' -> Buffer.add_char buffer '\\' | _ -> ()) ;
          Buffer.add_char buffer c
        done ;
        Buffer.add_char buffer '"' ;
        Buffer.contents buffer)
      else string

let add_parentheses s = "(" ^ s ^ ")"

let show ?(always_parenthesize = false) expression =
  let rec show context (expression : TSL_AST.t) =
    let parentheses_for_predicate =
      if always_parenthesize then add_parentheses
      else
        match context with
        | SC_not -> add_parentheses
        | SC_and | SC_or | SC_toplevel -> Fun.id
    in
    match expression with
    | True -> "true"
    | False -> "false"
    | String_predicate (var, Is value) ->
        parentheses_for_predicate
          (show_string_var var ^ " = " ^ show_string value)
    | String_predicate (var, Matches value) ->
        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
    | Not p -> "not " ^ show SC_not p
    | And (a, b) ->
        let parentheses =
          if always_parenthesize then add_parentheses
          else
            match context with
            | SC_not -> add_parentheses
            | SC_and | SC_or | SC_toplevel -> Fun.id
        in
        parentheses (show SC_and a ^ " && " ^ show SC_and b)
    | Or (a, b) ->
        let parentheses =
          if always_parenthesize then add_parentheses
          else
            match context with
            | SC_not | SC_and -> add_parentheses
            | SC_or | SC_toplevel -> Fun.id
        in
        parentheses (show SC_or a ^ " || " ^ show SC_or b)
  in
  show SC_toplevel expression

(* 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
  | Or (a, b) -> eval env a || eval env b

let conjunction = function
  | [] -> TSL_AST.True
  | head :: tail -> List.fold_left (fun a b -> TSL_AST.And (a, b)) head tail

let tags expression =
  let rec gather acc : TSL_AST.t -> _ = function
    | 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
  in
  String_set.elements (gather String_set.empty expression)