infer_clone/facebook-clang-plugins/clang-ocaml/utils.ml

(*
 * Copyright (c) 2014-present, Facebook, Inc.
 *
 * This source code is licensed under the MIT license found in the
 * LICENSE file in the root directory of this source tree.
 *)

module H = Hashtbl

(* misc *)
(* maps '-' to the standard input *)
let open_in name = if name = "-" then stdin else Pervasives.open_in name

(* maps '-' to the standard output *)
let open_out name = if name = "-" then stdout else Pervasives.open_out name

let make_cached f =
  let h = H.create 10 in
  function
    | x ->
      try H.find h x with Not_found ->
        let y = f x in
        H.add h x y ; y


(* missing string API *)

let string_starts_with s1 s2 =
  try
    let n = String.length s2 in
    String.sub s1 0 n = s2
  with Invalid_argument _ -> false


let string_ends_with s1 s2 =
  try
    let n = String.length s2 in
    String.sub s1 (String.length s1 - n) n = s2
  with Invalid_argument _ -> false


let string_split c s =
  let len = String.length s in
  let rec aux acc pos =
    if pos >= len then "" :: acc
    else
      try
        let next = String.index_from s pos c in
        aux (String.sub s pos (next - pos) :: acc) (next + 1)
      with Not_found -> String.sub s pos (String.length s - pos) :: acc
  in
  List.rev (aux [] 0)


let string_join c l = String.concat (String.make 1 c) l

(* lists *)

let rec list_starts_with l1 l2 =
  match (l1, l2) with
  | _, [] ->
      true
  | x1 :: q1, x2 :: q2 when x1 = x2 ->
      list_starts_with q1 q2
  | _ ->
      false


let list_ends_with l1 l2 = list_starts_with (List.rev l1) (List.rev l2)

(* missing stream API *)

let line_stream_of_channel channel =
  Stream.from (fun _ -> try Some (input_line channel) with End_of_file -> None)


let stream_concat streams =
  let current_stream = ref None in
  let rec next i =
    try
      let stream =
        match !current_stream with
        | Some stream ->
            stream
        | None ->
            let stream = Stream.next streams in
            current_stream := Some stream ;
            stream
      in
      try Some (Stream.next stream) with Stream.Failure ->
        current_stream := None ;
        next i
    with Stream.Failure -> None
  in
  Stream.from next


let stream_append s1 s2 = stream_concat (Stream.of_list [s1; s2])

let stream_map f stream =
  let rec next _ = try Some (f (Stream.next stream)) with Stream.Failure -> None in
  Stream.from next


let stream_filter p stream =
  let rec next i =
    try
      let value = Stream.next stream in
      if p value then Some value else next i
    with Stream.Failure -> None
  in
  Stream.from next


let stream_fold f init stream =
  let result = ref init in
  Stream.iter (fun x -> result := f x !result) stream ;
  !result


let stream_to_list s = List.rev (stream_fold (fun x l -> x :: l) [] s)

(* simplistic unit testing *)

let string_counters = Hashtbl.create 10

let assert_true s b =
  ( try
      let i = Hashtbl.find string_counters s in
      Hashtbl.replace string_counters s (i + 1)
    with Not_found -> Hashtbl.add string_counters s 1 ) ;
  if not b then (
    Printf.fprintf stderr "%s (%d)\n" s (Hashtbl.find string_counters s) ;
    exit 1 )
  else ()


let assert_false s b = assert_true s (not b)

let assert_equal s x y = assert_true s (x = y)

(* union-find data structure *)

module DisjointSet = struct
  type 'a bucket = {mutable parent: 'a; mutable rank: int}

  type 'a t = ('a, 'a bucket) Hashtbl.t

  let create () = Hashtbl.create 10

  let bucket t x =
    try Hashtbl.find t x with Not_found ->
      let b = {parent= x; rank= 0} in
      Hashtbl.add t x b ; b


  let rec find_bucket t x =
    let b = bucket t x in
    if b.parent = x then b
    else
      let b0 = find_bucket t b.parent in
      b.parent <- b0.parent ;
      b0


  let find t x = (find_bucket t x).parent

  let union t x y =
    let bx = find_bucket t x and by = find_bucket t y in
    if bx.parent <> by.parent then
      if bx.rank < by.rank then bx.parent <- by.parent
      else (
        by.parent <- bx.parent ;
        if bx.rank = by.rank then bx.rank <- bx.rank + 1 )


  let iter t f = Hashtbl.iter (fun x b -> f x (if x = b.parent then x else find t b.parent)) t
end

(* Helper for command line parsing with Arg *)

let fix_arg_spec l usage_msg =
  let result = ref [] in
  let usage () =
    Arg.usage !result usage_msg ;
    exit 0
  in
  let extra =
    [ ("-h", Arg.Unit usage, " Display this list of options.")
    ; ("-help", Arg.Unit usage, " ")
    ; ("--help", Arg.Unit usage, " ") ]
  in
  result := Arg.align (l @ extra) ;
  !result