Source file utils.ml

(**************************************************************************)
(*                                                                        *)
(*                 ACG development toolkit                                *)
(*                                                                        *)
(*                  Copyright 2008-2023 INRIA                             *)
(*                                                                        *)
(*  More information on "https://acg.loria.fr/"                     *)
(*  License: CeCILL, see the LICENSE file or "http://www.cecill.info"     *)
(*  Authors: see the AUTHORS file                                         *)
(*                                                                        *)
(*                                                                        *)
(*                                                                        *)
(*                                                                        *)
(*                                                                        *)
(**************************************************************************)

module StringSet = Set.Make (String)
module StringMap = Map.Make (String)

module IntMap = Map.Make (struct
  type t = int

  let compare i j = i - j
end)

module IntSet = Set.Make (struct
  type t = int

  let compare i j = i - j
end)

let string_of_list sep to_string = function
  | [] -> ""
  | [ a ] -> to_string a
  | a :: tl ->
      let buf = Buffer.create 16 in
      let () = Buffer.add_string buf (to_string a) in
      let () =
        List.iter
          (fun s ->
            Buffer.add_string buf (Printf.sprintf "%s%s" sep (to_string s)))
          tl
      in
      Buffer.contents buf

let pp_list ?(sep = format_of_string ",@ ") ?(terminal = format_of_string "") ppf fmt l =
  let rec list_ppf_aux ppf fmt l =
    match l with
    | [] -> ()
    | [ a ] -> Format.fprintf fmt ("%a" ^^ terminal) ppf a 
    | a :: tl ->
        let () = Format.fprintf fmt ("%a" ^^ sep) ppf a in
        list_ppf_aux ppf fmt tl
  in
  Format.fprintf fmt "%a" (list_ppf_aux ppf) l

let pp_list_i ?(sep = format_of_string ",@ ") ?(terminal = format_of_string "") ppf fmt l =
  let rec list_ppf_aux i ppf fmt l =
    match l with
    | [] -> ()
    | [ a ] -> Format.fprintf fmt ("%a" ^^ terminal) ppf (i, a)
    | a :: tl ->
        let () = Format.fprintf fmt ("%a" ^^ sep) ppf (i, a) in
        list_ppf_aux (i+1) ppf fmt tl
  in
  Format.fprintf fmt "%a" (list_ppf_aux 1 ppf) l



let pp_text fmt text =
  let words = String.split_on_char ' ' text in
    pp_list ~sep:"@ " Format.pp_print_string fmt words


let rec intersperse (sep : 'a) : 'a list -> 'a list = function
  | [] -> []
  | [ a_1 ] -> [ a_1 ]
  | a_1 :: a_2 :: tl -> a_1 :: sep :: intersperse sep (a_2 :: tl)

let cycle (n : int) (xs : 'a list) : 'a list =
  let rec cycle_aux n ys acc =
    match (n, ys) with
    | 0, _ -> acc
    | _, [] -> cycle_aux n xs acc
    | _, hd :: tl -> cycle_aux (n - 1) tl (hd :: acc)
  in
  match xs with [] -> [] | _ -> List.rev @@ cycle_aux n xs []

let fold_left1 (f : 'a -> 'a -> 'a) (xs : 'a list) : 'a =
  match xs with
  | [] -> failwith "Empty list passed to fold_left1"
  | head :: tail -> List.fold_left f head tail

let f_set_size formatter =
  try
    let terminal_width, _ = ANSITerminal.size () in
    Format.pp_set_margin formatter terminal_width
  with Failure f ->
    let regexp = Str.regexp "ANSITerminal.size" in
    if Str.string_match regexp f 0 then
      Format.pp_set_margin formatter (max_int - 1)
    else raise (Failure f)

let sterm_set_size () = f_set_size Format.str_formatter
let term_set_size () = f_set_size Format.std_formatter
let fterm_set_size formatter = f_set_size formatter

let no_pp () =
  List.iter
    (fun formatter -> Format.pp_set_margin formatter (max_int - 1))
    [ Format.std_formatter; Format.str_formatter ]

let fformat formatter format = Format.fprintf formatter format
let format format = fformat Format.std_formatter format
let sformat format = fformat Format.str_formatter format

let format_of_list fmter sep to_string = function
  | [] -> ()
  | [ a ] -> fformat fmter "@[%s@]" (to_string a)
  | a :: tl ->
      let () = fformat fmter "@[%s@]" (to_string a) in
      List.iter (fun s -> fformat fmter "%s@,@[%s@]" sep (to_string s)) tl

let bold_pp s = Fmt.(styled `Bold string) s
let blue_pp s = Fmt.(styled `Blue bold_pp) s
let red_pp s = Fmt.(styled `Red bold_pp) s
let green_pp s = Fmt.(styled `Green bold_pp) s
let magenta_pp s = Fmt.(styled `Magenta bold_pp) s
let yellow_pp s = Fmt.(styled `Yellow bold_pp) s

let fun_pp = red_pp
let sig_pp = green_pp
let lex_pp = yellow_pp
let terms_pp = magenta_pp
let binary_pp = bold_pp


let string_of_list_rev sep to_string lst =
  let buf = Buffer.create 16 in
  let rec string_of_list_rev_rec k = function
    | [] -> k ()
    | [ a ] ->
        let () = Buffer.add_string buf (to_string a) in
        k ()
    | a :: tl ->
        string_of_list_rev_rec
          (fun () ->
            let () =
              Buffer.add_string buf (Printf.sprintf "%s%s" sep (to_string a))
            in
            k ())
          tl
  in
  let () = string_of_list_rev_rec (fun () -> ()) lst in
  Buffer.contents buf

module FileErrors_l =
  struct
    type t =
      | FileNotFound of string
      | IsADirectory of string

    let kind = "File"

    let pp fmt  = function
      | FileNotFound f -> Format.fprintf fmt "Can't@ open@ file@ \"%s\"@ (not@ found)" f
      | IsADirectory d -> Format.fprintf fmt "Can't@ open@ file@ \"%s\"@ (it@ is@ a@ directory)" d
  end

module FileErrors = Error.ErrorManager(FileErrors_l)


(** [find_file f dirs msg] tries to find a file with the name [f] in
     the directories listed in [dirs]. If it finds it in [dir], it
     returns the full name [Filename.concat dir f]. To check in the
     current directory, add [""] to the list. It tries in the
     directories of [dirs] in this order and stops when it finds such
     a file. If it can't find any such file, raise the exception
     {!Utils.No_file(f,msg)}. Moreover, if [f] starts with ["/"] or
     ["./"] or ["../"] then it checks wheter [f] exists only in the
     current directory.*)
let find_file name dirs loc =
  let regexp = Str.regexp "\\(^\\./\\)\\|\\(^\\.\\./\\)\\|\\(^/\\)" in
  let check_dirs = not (Str.string_match regexp name 0) in
  let get_name f =
    if Sys.file_exists f then
      if not (Sys.is_directory f) then Some f
      else FileErrors.emit (FileErrors_l.IsADirectory name) ~loc
    else None
  in
  let rec rec_find_file = function
    | [] -> FileErrors.emit (FileErrors_l.FileNotFound name) ~loc
    | dir :: dirs -> (
        match get_name (Filename.concat dir name) with
        | Some f -> f
        | None -> rec_find_file dirs)
  in
  if check_dirs then rec_find_file dirs else 
    match get_name name with
   | Some f -> f
   | None -> FileErrors.emit (FileErrors_l.FileNotFound name) ~loc

let ( >> ) f g x = f (g x)

(*
let log_iteration log_function s =
  List.iter
    log_function
    (Bolt.Utils.split "\n" s)
                           *)

let decompose ~input ~base =
  let rec decompose_aux i b res =
    let q = i / b in
    let r = i mod b in
    match q with 0 -> r :: res | _ -> decompose_aux q base (r :: res)
  in
  decompose_aux input base []

module type MapToSet = functor (_ : Set.S) -> Map.S