hphp/hack/src/utils/utils.ml

   1 (**
   2  * Copyright (c) 2015, Facebook, Inc.
   3  * All rights reserved.
   4  *
   5  * This source code is licensed under the MIT license found in the
   6  * LICENSE file in the "hack" directory of this source tree.
   7  *
   8  *)
   9
  10 open Hh_core
  11
  12 (** Callstack is simply a typed way to indicate that a string is a callstack *)
  13 type callstack = Callstack of string
  14
  15 let () = Random.self_init ()
  16 let debug = ref false
  17 let profile = ref false
  18
  19 let log = ref (fun (_ : string)  -> ())
  20
  21 let d s =
  22   if !debug
  23   then begin
  24     print_string s;
  25     flush stdout;
  26   end
  27
  28 let dn s =
  29   if !debug
  30   then begin
  31     print_string s;
  32     print_newline();
  33     flush stdout;
  34   end
  35
  36 module Map = struct end
  37
  38 let spf = Printf.sprintf
  39 let print_endlinef fmt = Printf.ksprintf print_endline fmt
  40 let prerr_endlinef fmt = Printf.ksprintf prerr_endline fmt
  41
  42 let opt f env = function
  43   | None -> env, None
  44   | Some x -> let env, x = f env x in env, Some x
  45
  46 let opt_fold f env = function
  47   | None -> env
  48   | Some x -> f env x
  49
  50 let singleton_if cond x = if cond then [x] else []
  51
  52 let smap_inter m1 m2 =
  53   SMap.fold (
  54   fun x y acc ->
  55     if SMap.mem x m2
  56     then SMap.add x y acc
  57     else acc
  58  ) m1 SMap.empty
  59
  60 let imap_inter m1 m2 =
  61   IMap.fold (
  62   fun x y acc ->
  63     if IMap.mem x m2
  64     then IMap.add x y acc
  65     else acc
  66  ) m1 IMap.empty
  67
  68 let smap_inter_list = function
  69   | [] -> SMap.empty
  70   | x :: rl ->
  71       List.fold_left rl ~f:smap_inter ~init:x
  72
  73 let imap_inter_list = function
  74   | [] -> IMap.empty
  75   | x :: rl ->
  76       List.fold_left rl ~f:imap_inter ~init:x
  77
  78 let rec wfold_left2 f env l1 l2 =
  79   match l1, l2 with
  80   | [], _ | _, [] -> env
  81   | x1 :: rl1, x2 :: rl2 ->
  82       let env = f env x1 x2 in
  83       wfold_left2 f env rl1 rl2
  84
  85 let sl l =
  86   List.fold_right l ~f:(^) ~init:""
  87
  88 let maybe f env = function
  89   | None -> ()
  90   | Some x -> f env x
  91
  92 (* Since OCaml usually runs w/o backtraces enabled, the note makes errors
  93  * easier to debug. *)
  94 let unsafe_opt_note note = function
  95   | None -> raise (Invalid_argument note)
  96   | Some x -> x
  97
  98 let unsafe_opt x = unsafe_opt_note "unsafe_opt got None" x
  99
 100 let inter_list = function
 101   | [] -> SSet.empty
 102   | x :: rl ->
 103       List.fold_left rl ~f:SSet.inter ~init:x
 104
 105 let rec list_last f1 f2 =
 106   function
 107     | [] -> ()
 108     | [x] -> f2 x
 109     | x :: rl -> f1 x; list_last f1 f2 rl
 110
 111 let is_prefix_dir dir fn =
 112   let prefix = dir ^ Filename.dir_sep in
 113   String.length fn > String.length prefix &&
 114   String.sub fn 0 (String.length prefix) = prefix
 115
 116 let try_with_channel (oc: out_channel) (f1: out_channel -> 'a) (f2: exn -> 'a) : 'a =
 117   try
 118     let result = f1 oc in
 119     close_out oc;
 120     result
 121   with e ->
 122     close_out oc;
 123     f2 e
 124
 125 let try_with_stack (f: unit -> 'a) : ('a, exn * callstack) result =
 126   try
 127     Ok (f ())
 128   with exn ->
 129     let stack = Callstack (Printexc.get_backtrace ()) in
 130     Error (exn, stack)
 131
 132
 133 let iter_n_acc n f acc =
 134   let acc = ref acc in
 135   for i = 1 to n-1 do
 136     acc := fst (f !acc)
 137   done;
 138   f !acc
 139
 140 let map_of_list list =
 141   List.fold_left ~f:(fun m (k, v) -> SMap.add k v m) ~init:SMap.empty list
 142
 143 let set_of_list l =
 144   List.fold_right l ~f:SSet.add ~init:SSet.empty
 145
 146 (* \A\B\C -> A\B\C *)
 147 let strip_ns s =
 148   if String.length s == 0 || s.[0] <> '\\' then s
 149   else String.sub s 1 ((String.length s) - 1)
 150
 151 (* A\B\C -> \A\B\C *)
 152 let add_ns s =
 153   if String.length s = 0 || s.[0] <> '\\'
 154   then "\\" ^ s
 155   else s
 156
 157 (* \A\B\C -> C *)
 158 let strip_all_ns s =
 159   try
 160     let base_name_start = String.rindex s '\\' + 1 in
 161     String.sub s base_name_start ((String.length s) - base_name_start)
 162   with Not_found -> s
 163
 164 (* "\\A\\B\\C" -> ("\\A\\B\\" * "C") *)
 165 let split_ns_from_name (s: string): (string * string) =
 166   try
 167     let base_name_start = (String.rindex s '\\') + 1 in
 168     let name_part = String.sub s
 169       (base_name_start)
 170       ((String.length s) - base_name_start) in
 171     let namespace_part = String.sub s 0 base_name_start in
 172     (namespace_part, name_part)
 173   with Not_found -> ("\\", s)
 174
 175 (*****************************************************************************)
 176 (* Same as List.iter2, except that we only iterate as far as the shortest
 177  * of both lists.
 178  *)
 179 (*****************************************************************************)
 180
 181 let rec iter2_shortest f l1 l2 =
 182   match l1, l2 with
 183   | [], _ | _, [] -> ()
 184   | x1 :: rl1, x2 :: rl2 -> f x1 x2; iter2_shortest f rl1 rl2
 185
 186 let fold_fun_list acc fl =
 187   List.fold_left fl ~f:(|>) ~init:acc
 188
 189 let compose f g x = f (g x)
 190
 191 module With_complete_flag = struct
 192   type 'a t = {
 193     is_complete : bool;
 194     value : 'a;
 195   }
 196 end
 197
 198 let try_finally ~f ~(finally: unit -> unit) =
 199   let res = try f () with e -> finally (); raise e in
 200   finally ();
 201   res
 202
 203 let with_context ~enter ~exit ~do_ =
 204   enter ();
 205   let result = try do_ () with e ->
 206     let stack = Printexc.get_raw_backtrace () in
 207     exit ();
 208     Printexc.raise_with_backtrace e stack in
 209   exit ();
 210   result
 211
 212 (* We run with exception backtraces turned off for performance reasons. But for
 213  * some kinds of catastrophic exceptions, which we never recover from (so the
 214  * performance doesn't matter) we do want the backtrace. "assert false" is one
 215  * of such conditions.
 216  *)
 217 let assert_false_log_backtrace msg =
 218   Printf.eprintf "assert false with backtrace:\n";
 219   Option.iter msg ~f:(Printf.eprintf "%s\n");
 220   Printf.eprintf "%s" (Printexc.raw_backtrace_to_string
 221     (Printexc.get_callstack 100));
 222   assert false
 223
 224 (* Returns the largest element in arr strictly less than `bound` *)
 225 let infimum (arr : 'a array)
 226             (bound : 'b)
 227             (compare : 'a -> 'b -> int) : int option =
 228   let rec binary_search low high = begin
 229     if low = high then
 230       Some low
 231     else if low > high then
 232       None
 233     else begin
 234       let mid = (low + high + 1) / 2 in
 235       let test = Array.get arr mid in
 236       if compare test bound < 0 then
 237         binary_search mid high
 238       else
 239         binary_search low (mid - 1)
 240     end
 241   end in
 242   binary_search 0 ((Array.length arr) - 1)
 243
 244 let unwrap_snd (a, b_opt) =
 245   match b_opt with
 246   | None -> None
 247   | Some b -> Some (a, b)