Source file misc.ml

(*********************************************************************************)
(*                Chamo                                                          *)
(*                                                                               *)
(*    Copyright (C) 2003-2021 Institut National de Recherche en Informatique     *)
(*    et en Automatique. All rights reserved.                                    *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU Lesser General Public License version        *)
(*    3 as published by the Free Software Foundation.                            *)
(*                                                                               *)
(*    This program is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the              *)
(*    GNU General Public License for more details.                               *)
(*                                                                               *)
(*    You should have received a copy of the GNU General Public License          *)
(*    along with this program; if not, write to the Free Software                *)
(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

(** Misc *)

let map_opt f = function
    None -> None
  | Some v -> Some (f v)


let rec my_int_of_string s =
  let len = String.length s in
  if len <= 0 then invalid_arg "my_int_of_string";
  match s.[0] with
    '+' -> my_int_of_string (String.sub s 1 (len - 1))
  | _ -> int_of_string s


let add_shortcut w l (ks, action) =
  try
    let (c_opt, f) = List.assoc action l in
    Stk.Wkey.add w ?cond: c_opt ks f
  with
    Not_found ->
      Log.err (fun m -> m "%s" (Messages.error_unknown_action action))
;;

let remove_char s c =
  let s = Bytes.of_string s in
  let len = Bytes.length s in
  if len > 0 then
    for i = 0 to len - 1 do
      if Bytes.get s i = c then Bytes.set s i ' '
    done;
  Bytes.to_string s

let line_of_char file n =
  try
    let chanin = open_in file in
    let rec iter l m =
      let s_opt =
        try Some (input_line chanin)
        with End_of_file -> None
      in
      match s_opt with
        None -> l
      | Some s ->
          let new_m = m + ((String.length s) + 1) in (* + 1 is for '\n' *)
          if new_m >= n then
            l
          else
            iter (l + 1) new_m
    in
    let l = iter 0 0 in
    close_in chanin ;
    l
  with
    Sys_error s ->
      prerr_endline s ;
      0

let char_of_line file n =
  let ic = open_in file in
  let rec iter acc l =
    if l >= n then
      acc
    else
      match
        try Some (String.length (input_line ic))
        with End_of_file -> None
      with
        None -> acc
      | Some n -> iter (acc+n+1) (l+1) (* acc+n+1 for the newline character *)
  in
  let n = iter 0 0 in
  close_in ic;
  n
;;

let mod_date_of_file file =
  try (Unix.stat file).Unix.st_mtime
  with _ -> 0.0

let catch_print_exceptions f x =
  try f x
  with
    e ->
      let s =
        match e with
          Failure s
        | Sys_error s -> s
        | Unix.Unix_error (e,s1,s2) ->
            Printf.sprintf "%s: %s %s" (Unix.error_message e) s1 s2
        | e -> Printexc.to_string e
      in
      Log.err (fun m -> m "%s" s)



let to_utf8 ?(coding=Ocf.get Core_rc.encoding) s =
  Iconv.iconv_string ~fromcode:coding ~tocode:"UTF-8" s

let pp_to_utf8 ppf s = Format.pp_print_string ppf (to_utf8 s)

let of_utf8 ?(coding=Ocf.get Core_rc.encoding) s =
  Iconv.iconv_string ~fromcode:"UTF-8" ~tocode:coding s

let chop_n_char n s =
  let len = String.length s in
  if len <= n +1 || n < 0 then
    s
  else
    Printf.sprintf "%s..." (String.sub s 0 (n+1))

let list_remove_doubles ?(pred=(=)) l =
  List.fold_left
    (fun acc e -> if List.exists (pred e) acc then acc else e :: acc)
    []
    (List.rev l)

let subdirs path =
  let d = Unix.opendir path in
  let rec iter acc =
    let file =
      try Some (Unix.readdir d)
      with End_of_file -> Unix.closedir d; None
    in
    match file with
    | None -> List.rev acc
    | Some s when
          s = Filename.current_dir_name ||
          s = Filename.parent_dir_name -> iter acc
    | Some file ->
        let complete_f = Filename.concat path file in
	match
	  try Some (Unix.stat complete_f).Unix.st_kind
	  with _ -> None
	with
	  Some Unix.S_DIR -> iter (complete_f :: acc)
	| None | Some _ -> iter acc
  in
  iter []

let replace_in_string ~pat ~subs ~s =
  let len_pat = String.length pat in
  let len = String.length s in
  let b = Buffer.create len in
  let rec iter pos =
    if pos >= len then
      ()
    else
      if pos + len_pat > len then
        Buffer.add_string b (String.sub s pos (len - pos))
      else
        if String.sub s pos len_pat = pat then
          (
           Buffer.add_string b subs;
           iter (pos+len_pat)
          )
        else
          (
           Buffer.add_char b s.[pos];
           iter (pos+1);
          )
  in
  iter 0;
  Buffer.contents b

let escape_menu_label s = replace_in_string ~pat: "_" ~subs: "__" ~s

let string_of_file name =
  let chanin = open_in_bin name in
  let len = 1024 in
  let s = Bytes.create len in
  let buf = Buffer.create len in
  let rec iter () =
    try
      let n = input chanin s 0 len in
      if n = 0 then
        ()
      else
        (
         Buffer.add_subbytes buf s 0 n;
         iter ()
        )
    with
      End_of_file -> ()
  in
  iter ();
  close_in chanin;
  Buffer.contents buf

let file_of_string ~file s =
  let oc = open_out file in
  output_string oc s;
  close_out oc

let try_finalize f x finally y =
  let res =
    try f x
    with exn -> finally y; raise exn
  in
  finally y;
  res

let no_blanks s =
  let len = String.length s in
  let buf = Buffer.create len in
  for i = 0 to len - 1 do
    match s.[i] with
      ' ' | '\n' | '\t' | '\r' -> ()
    | c -> Buffer.add_char buf c
  done;
  Buffer.contents buf

let split_string ?(keep_empty=false) s chars =
  let len = String.length s in
  let rec iter acc pos =
    if pos >= len then
      match acc with
        "" -> if keep_empty then [""] else []
      | _ -> [acc]
    else
      if List.mem s.[pos] chars then
        match acc with
          "" ->
            if keep_empty then
              "" :: iter "" (pos + 1)
            else
              iter "" (pos + 1)
        | _ -> acc :: (iter "" (pos + 1))
      else
        iter (Printf.sprintf "%s%c" acc s.[pos]) (pos + 1)
  in
  iter "" 0

let make_list n ele =
  let rec f acc n =
    if n > 0 then f (ele :: acc) (n-1) else acc
  in
  f [] n

let safe_remove_file file =
  try Sys.remove file
  with Sys_error _ -> ()

(** {2 Getting canonical filenames} *)

let equal_node n1 n2 =
  n1.Unix.st_ino = n2.Unix.st_ino && n1.Unix.st_dev = n2.Unix.st_dev;;

let set_active_state_message msg =
  Commands.async_launch_command "set_active_state_message" [|msg|]
let set_active_action_message msg =
  Commands.async_launch_command "set_active_action_message" [|msg|]
let display_message msg =
  Log.app (fun m -> m "%s" msg);
  set_active_action_message msg
let warning_message msg =
  Log.warn (fun m -> m "%s" msg);
  set_active_action_message msg
let error_message msg =
  Log.err (fun m -> m "%s" msg) ;
  set_active_action_message msg


let fail_if_unix_error f x =
  try f x
  with Unix.Unix_error (e,s1,s2) ->
    failwith ((Unix.error_message e)^": "^s1^" "^s2)

let is_prefix s1 s2 =
  let len1 = String.length s1 in
  let len2 = String.length s2 in
  len1 >= len2 && (String.sub s1 0 len2) = s2

let dir_entries ?prefix dir =
(*
  prerr_endline (Printf.sprintf "dir_entries: prefix=%s dir=%s"
		   (match prefix with None -> "" | Some s -> s)
		   dir);
*)
  let d = fail_if_unix_error Unix.opendir dir in
  let rec iter acc =
    let name_opt =
      try Some (Unix.readdir d)
      with End_of_file ->
	Unix.closedir d;
	None
    in
    match name_opt with
      None -> List.rev acc
    | Some name ->
	let acc =
	  match prefix with
	    None -> name::acc
	  | Some s ->
	      if is_prefix name s then
		name :: acc
	      else
		acc
	in
	iter acc
  in
  iter []

let max_common l =
  let pred char n s =
    String.length s >= (n+1) && s.[n] = char
  in
  let in_all c n = List.for_all (pred c n) l in
  match l with
    [] -> None
  | [s] -> Some s
  | h :: q ->
      let len = String.length h in
      let rec iter n =
	if n < len then
	  if in_all h.[n] n then
	    iter (n+1)
	  else
	    n
	else
	  len
      in
      let maxlen = iter 0 in
      Some (String.sub h 0 maxlen)

(* when converting a filename from and to utf-8, using an
  empty code result in using the locale encoding. *)
let filename_to_utf8 str =
  Iconv.iconv_string ~fromcode:"" ~tocode:"UTF-8" str
let filename_from_utf8 str =
  Iconv.iconv_string ~fromcode:"UTF-8" ~tocode:"" str

let select_file_history = Minibuffer.history ()
let select_file (mb : Minibuffer.minibuffer) ~title text f =
  let get_user_text () =
    let s = mb#get_user_text in
    let s = filename_from_utf8 s in
    let len = String.length s in
    let s =
      if len > 0 && s.[0] = '~' then
        Printf.sprintf "%s%s"
          Config.home
        (String.sub s 1 (len - 1))
      else
        s
    in
    s
  in
  let on_complete () =
    let s = get_user_text () in
    try
      let is_dir =
        try (fail_if_unix_error Unix.stat s).Unix.st_kind = Unix.S_DIR
        with Failure _ -> false
      in
      let len = String.length s in
      let (list, text) =
        if is_dir && s.[len-1] = '/' then
          (
           let entries = dir_entries s in
           (entries, s)
          )
        else
          (
           let dir = Filename.dirname s in
           let prefix = Filename.basename s in
           let entries = dir_entries ~prefix dir in
           match max_common entries with
             None -> (["[no match]"], s)
           | Some s ->
               let s = Filename.concat dir s in
               match entries with
                 [_] ->
                   if is_dir then
                     ([], s^"/")
                   else
                     ([], s)
	       | _ -> (entries, s)
          )
      in
      let (utf8_list, badly_encoded) =
        List.fold_right
          (fun f (acc, n) ->
             try
               ((filename_to_utf8 f) :: acc, n)
             with _ -> (acc, n+1)
          )
          list
          ([], 0)
      in
      let fixed =
        Printf.sprintf "%s%s: "
          (if badly_encoded > 1 then
             Printf.sprintf "[%d badly encoded entries] " badly_encoded
           else "")
          title
      in
      mb#set_text
        ~list: utf8_list
        ~fixed
        (filename_to_utf8 text)
    with
      Failure err ->
        mb#set_text ~list: [to_utf8 err] ~fixed: (title^": ") s
  in
  mb#clear;
  let on_eval () =
    let s = filename_from_utf8 (get_user_text ())in
    let () = mb#set_text "" in
    let () = mb#set_active false in
    match s with
      "" -> Lwt.return_unit
    | _ -> f s
  in
  let () = mb#set_text ~fixed: (title^": ") text in
  mb#set_on_eval on_eval;
  mb#set_on_complete on_complete;
  mb#set_history select_file_history;
  mb#set_active true;
  mb#wait
(*
  let dir = match dir with None -> None | Some s -> Some (ref s) in
  GToolbox.select_file ~title ?dir ()
*)

let select_string ?history (mb : Minibuffer.minibuffer) ~title ~choices text f =
  let on_complete () =
    let s = mb#get_user_text in
    let s = of_utf8 s in
    let entries = List.filter
        (fun choice -> is_prefix choice s)
        choices
    in
    let (list,text) =
      match max_common entries with
        None -> (["[No match]"], s)
      | Some s ->
          match entries with
            [_] -> ([], s)
          | _ -> (entries, s)
    in
    mb#set_text
      ~list: (List.map (to_utf8 ?coding:None) list)
      ~fixed: (title^": ")
      (to_utf8 text)
  in
  let on_eval () =
    let s = mb#get_user_text in
    let s = of_utf8 s in
    mb#set_text "";
    mb#set_active false;
    f s
  in
  mb#clear ;
  mb#set_text ~fixed: (title^": ") text ;
  (match history with None -> () | Some h -> mb#set_history h);
  mb#set_on_eval on_eval;
  mb#set_on_complete on_complete;
  mb#set_active true;
  mb#wait

let input_string ?history (mb : Minibuffer.minibuffer) ~title text f =
  let on_complete () = () in
  let on_eval () =
    let s = mb#get_user_text in
    let s = of_utf8 s in
    mb#set_text "" ;
    mb#set_active false ;
    f s
  in
  mb#clear ;
  mb#set_text ~fixed: (title^": ") text ;
  (match history with None -> () | Some h -> mb#set_history h);
  mb#set_on_eval on_eval;
  mb#set_on_complete on_complete;
  mb#set_active true;
  mb#wait

let input_command_arg mb ?history ~title f com args =
  let ask ?err text =
    let f s =
      let com = Printf.sprintf "%s %s" com s in
      Commands.eval_command com
    in
    let title = Printf.sprintf "%s%s"
        (match err with None -> "" | Some s -> "["^s^"] ")
        title
    in
    input_string ?history mb ~title text f
  in
  let len = Array.length args in
  if len > 0 then
    try f args.(0)
    with Invalid_argument err -> ask ~err args.(0)
  else
    ask ""

let confirm (mb : Minibuffer.minibuffer) text f =
  let g () =
    let s = mb#get_user_text in
    let s = of_utf8 s in
    mb#set_text "" ;
    mb#set_active false ;
    if String.length s > 0 then
      match s.[0] with
        'y'|'Y' -> f ()
      | _ -> Lwt.return_unit
    else
      Lwt.return_unit
  in
  mb#clear ;
  mb#set_text ~fixed: (Printf.sprintf "%s (y/n) " text) "" ;
  mb#set_on_eval g;
  mb#set_active true;
  mb#wait

let string_of_bool = function
  true -> "true"
| false -> "false"

let bool_of_string = function
  "true" -> true
| _ -> false

let date_of_file filename =
  try Some ((Unix.stat filename).Unix.st_mtime)
  with _ -> None

let same_files f1 f2 =
  let f () =
    let st1 = Unix.stat f1
    and st2 = Unix.stat f2 in
    st1.Unix.st_dev = st2.Unix.st_dev &&
    st1.Unix.st_ino = st2.Unix.st_ino
  in
  fail_if_unix_error f ()

let safe_same_files f1 f2 =
  try same_files f1 f2 with _ -> false