ocaml/ocamltest/environments.ml

(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
(*                                                                        *)
(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* Definition of environments, used to pass parameters to tests and actions *)

open Ocamltest_stdlib

module VariableMap = Map.Make (Variables)

type t = string VariableMap.t

let empty = VariableMap.empty

let to_bindings env =
  let f variable value lst = (variable, value) :: lst in
  VariableMap.fold f env []

let expand_aux env value =
  let bindings = to_bindings env in
  let f (variable, value) = ((Variables.name_of_variable variable), value) in
  let simple_bindings = List.map f bindings in
  let subst s = try (List.assoc s simple_bindings) with Not_found -> "" in
  let b = Buffer.create 100 in
  try Buffer.add_substitute b subst value; Buffer.contents b with _ -> value

let rec expand env value =
  let expanded = expand_aux env value in
  if expanded=value then value else expand env expanded

let to_system_env env =
  let system_env = Array.make (VariableMap.cardinal env) "" in
  let i = ref 0 in
  let store variable value =
    system_env.(!i) <-
      Variables.string_of_binding variable (expand env value);
    incr i in
  VariableMap.iter store env;
  system_env

let lookup variable env =
  try Some (expand env (VariableMap.find variable env)) with Not_found -> None

let lookup_nonempty variable env = match lookup variable env with
  | None -> None
  | Some x as t -> if String.words x = [] then None else t

let lookup_as_bool variable env =
  match lookup variable env with
  | None -> None
  | Some "true" -> Some true
  | Some _ -> Some false

let safe_lookup variable env = match lookup variable env with
  | None -> ""
  | Some value -> value

let is_variable_defined variable env =
  VariableMap.mem variable env

let add variable value env = VariableMap.add variable value env

let add_if_undefined variable value env =
  if VariableMap.mem variable env then env else add variable value env

let append variable appened_value environment =
  let previous_value = safe_lookup variable environment in
  let new_value = previous_value ^ appened_value in
  VariableMap.add variable new_value environment

let remove = VariableMap.remove

let add_bindings bindings env =
  let f env (variable, value) = add variable value env in
  List.fold_left f env bindings

let from_bindings bindings = add_bindings bindings empty

let dump_assignment log (variable, value) =
  Printf.fprintf log "%s = %s\n%!" (Variables.name_of_variable variable) value

let dump log environment =
  List.iter (dump_assignment log) (VariableMap.bindings environment)

(* Initializers *)

type env_initializer = out_channel -> t -> t

let (initializers : (string, env_initializer) Hashtbl.t) = Hashtbl.create 10

let register_initializer name code = Hashtbl.add initializers name code

let apply_initializer _log _name code env =
  code _log env

let initialize log env =
  let f = apply_initializer log in
  Hashtbl.fold f initializers env

(* Modifiers *)

type modifier =
  | Include of string
  | Add of Variables.t * string
  | Append of Variables.t * string
  | Remove of Variables.t

type modifiers = modifier list

exception Empty_modifiers_name
exception Modifiers_name_already_registered of string
exception Modifiers_name_not_found of string

let (registered_modifiers : (string, modifiers) Hashtbl.t) = Hashtbl.create 20

let register_modifiers name modifiers =
  if name="" then raise Empty_modifiers_name
  else if Hashtbl.mem registered_modifiers name
  then raise (Modifiers_name_already_registered name)
  else Hashtbl.add registered_modifiers name modifiers

let find_modifiers name =
  try Hashtbl.find registered_modifiers name
  with Not_found -> raise (Modifiers_name_not_found name)

let rec apply_modifier environment = function
  | Include modifiers_name ->
    apply_modifiers environment (find_modifiers modifiers_name)
  | Add (variable, value) -> add variable value environment
  | Append (variable, value) -> append variable value environment
  | Remove variable -> remove variable environment
and apply_modifiers environment modifiers =
  List.fold_left apply_modifier environment modifiers

let modifier_of_string str =
  let invalid_argument = (Invalid_argument "modifier_of_string") in
  if str="" then raise invalid_argument else begin
    let l = String.length str in
    if str.[0] = '-' then begin
      let variable_name = String.sub str 1 (l-1) in
      match Variables.find_variable variable_name with
        | None -> raise (Variables.No_such_variable variable_name)
        | Some variable -> Remove variable
    end else begin match String.index_opt str '=' with
      | None -> raise invalid_argument
      | Some pos_eq -> if pos_eq <= 0 then raise invalid_argument else
        let (append, varname_length) =
        (match String.index_opt str '+' with
        | None -> (false, pos_eq)
        | Some pos_plus ->
          if pos_plus = pos_eq-1
          then (true, pos_plus)
          else raise invalid_argument) in
        let variable_name = String.sub str 0 varname_length in
        match Variables.find_variable variable_name with
          | None -> raise (Variables.No_such_variable variable_name)
          | Some variable ->
            if pos_eq >= l-2 || str.[pos_eq+1]<>'"' || str.[l-1]<>'"'
            then raise invalid_argument
            else let value_length = l - pos_eq - 3 in
            let value = String.sub str (pos_eq+2) value_length in
            if append then Append (variable, value)
            else Add (variable, value)
    end
  end

let modifiers_of_file filename =
  let ic = open_in filename in
  let rec modifiers_of_lines acc = match input_line_opt ic with
    | None -> acc
    | Some line ->
      modifiers_of_lines ((modifier_of_string (String.trim line)) :: acc) in
  let modifiers = modifiers_of_lines [] in
  close_in ic;
  List.rev modifiers