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"

(* 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_string_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_string_predicate
          (show_string_var var ^ " = " ^ show_string value)
    | String_predicate (var, Matches value) ->
        parentheses_for_string_predicate
          (show_string_var var ^ " =~ " ^ show_string (show_rex 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

type env = {file : string; title : string; tags : string list}

let get_string : env -> TSL_AST.string_var -> string =
 fun env -> function File -> env.file | Title -> env.title

let apply_string_operator : string -> TSL_AST.string_operator -> bool =
 fun value -> function
  | Is expected -> String.equal value expected
  | Matches rex -> value =~ rex

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
  | 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), _) -> 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)