(**************************************************************************)
(*  Adaptated from:                                                       *)
(*  Mini, a type inference engine based on constraint solving.            *)
(*  Copyright (C) 2006. François Pottier, Yann Régis-Gianas               *)
(*  and Didier Rémy.                                                      *)
(*                                                                        *)
(*  This program is free software; you can redistribute it and/or modify  *)
(*  it under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation; version 2 of the License.               *)
(*                                                                        *)
(*  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., 51 Franklin Street, Fifth Floor, Boston, MA         *)
(*  02110-1301 USA                                                        *)
(*                                                                        *)
(**************************************************************************)

(** This module contains miscellaneous utilities. *)

(** [iter] is similar to [List.iter], but does not require [f] to
    return a result of type [unit]. Use with caution. *)
let rec iter f = function
  | [] ->
      ()
  | a :: l ->
      let _ = f a in
      iter f l

(** If [l] is a list of pairs of a key and a datum, and if [p] is a
    predicate on keys, then [assocp p l] returns the datum associated
    with the first key that satisfies [p] in [l]. It raises
    [Not_found] if no such key exists. *)
let rec assocp p = function
  | [] ->
      raise Not_found
  | (key, data) :: l ->
      if p key then data else assocp p l

(** Sets of strings. *)
module StringSet = Set.Make(String)

(** Maps over strings. *)
module StringMap = struct

  include Map.Make(String)

  let singleton key data =
    add key data empty

  exception Strict of string

  let strict_add key data m =
    try
      let _ = find key m in
      raise (Strict key)
    with Not_found ->
      add key data m

  let union m1 m2 =
    fold add m1 m2

  let strict_union m1 m2 =
    fold strict_add m1 m2

  let domain m =
    fold (fun k _ acu -> StringSet.add k acu) m StringSet.empty

end

(** A debugging flag. *)
let debug =
  ref true

(** Prints a list of elements, with one occurrence of the separator
    between every two consecutive elements. *)
let print_separated_list separator print_elem xs =

  let rec loop x = function
    | [] ->
        print_elem x
    | y :: xs ->
        print_elem x ^
        separator ^
        loop y xs
  in

  match xs with
  | [] ->
      ""
  | x :: xs ->
      loop x xs


let make_indexes default  =
  (** A hash table maps all known identifiers to integer values. It
      provides one direction of the global mapping. *)
  let table =
    Hashtbl.create 1023
  and
  (** An infinite array maps all known integer values to identifiers. It
      provides the other direction of the global mapping. *)
  array =
    InfiniteArray.make default (* Dummy data. *)
    (** A global counter contains the next available integer label. *)
  and counter =
    ref 0
  in
  (** [import s] associates a unique label with the identifier [s],
      possibly extending the global mapping if [s] was never encountered
      so far. Thus, if [s] and [t] are equal strings, possibly allocated
      in different memory locations, [import s] and [import t] return
      the same label. The identifier [s] is recorded and may be later
      recovered via [export]. *)
  let import s =
    try
      Hashtbl.find table s
    with Not_found ->
      let i = !counter in
      Hashtbl.add table s i;
      InfiniteArray.set array i s;
      counter := i + 1;
      i

  (** [export i] provides access to the inverse of the global mapping,
      that is, associates a unique identifier with every label. The
      identifier associated with a label is the one originally supplied
      to [import]. *)
  and export i =
    assert (i < !counter);
    InfiniteArray.get array i

  and find s =
    Hashtbl.find table s
  in
    (import, export, find)

(* FIXME: sort what is still necessary or not. *)

let rec last = function
    [] -> raise Not_found
  | [ a ] -> a
  | a :: q -> last q

let curry f = fun (x, y) -> f x y

let switch_args f = fun x y -> f y x

let safe_find x =
  try
    x
  with Not_found -> assert false

let notf f = fun x -> not (f x)

let eqf x = fun y -> y = x

let twice f x y = (f x, f y)

exception Inconsistency

let pmapq conv v =
  try
    List.assq v conv
  with Not_found -> v

let default d = function
    Some x -> x
  | None -> d

let is_now v v' =
  match v with
  | None -> v'
  | Some x -> if (v <> v') then raise Inconsistency else v

let rec itern n f =
  if n = 0 then [] else (f ()) :: (itern (n-1) f)

let updatef f x v = List.map (fun (y, v') -> if x = y then (x, f v) else (y, v'))

let update x v = updatef (fun x -> x) x v


let set_of_list =
  List.fold_left (fun a c -> StringSet.add c a) StringSet.empty

let intersect s1 s2 =
  StringSet.inter s1 s2 <> StringSet.empty

let map_union m1 m2 =
  StringMap.fold StringMap.add m1 m2

exception InvalidOptionUse

let unSome = function
  | None -> raise InvalidOptionUse
  | Some x -> x

let unSomef f = fun x -> unSome (f x)

let split3 l = List.fold_left (fun (l1,l2,l3) (a, b, c) -> a::l1, b::l2, c::l3)
               ([], [], []) l

let split4 l = List.fold_left
                 (fun (l1,l2,l3,l4) (a, b, c, d) -> a::l1, b::l2, c::l3, d::l4)
               ([], [], [], []) l

let split5 l =
  List.fold_left
    (fun (l1,l2,l3,l4,l5) (a, b, c, d, e) -> a::l1, b::l2, c::l3, d::l4, e::l5)
               ([], [], [], [], []) l

let rec transpose l =
  match l with
    | [] -> []
    | [] :: _ -> []
    | [ a ] :: _ -> [ List.map List.hd l ]
    | _ -> let hs, ts =
        List.split (List.map (function l -> List.hd l, List.tl l) l)
      in hs :: transpose ts

let list_unionq l1 =
  List.fold_left (fun acu x -> if not (List.memq x acu) then x::acu else acu)
    l1

let list_removeq x = function
  | [] -> []
  | a :: q when x == a -> q
  | l -> l

let const f = fun v -> f

let array_associ x a =
  let len = Array.length a in
  let rec chop i =
    if i < len then
      if fst a.(i) = x then i
      else chop (i + 1)
    else
      raise Not_found
  in
    chop 0

let array_assoc x a =
  snd a.(array_associ x a)

let assoc_proj1 l =
  fst (List.split l)

let assoc_proj2 l =
  snd (List.split l)

let proj1_3 (x,_,_) = x
let proj2_3 (_,y,_) = y
let proj3_3 (_,_,z) = z

let proj1_4 (x,_,_,_) = x
let proj2_4 (_,y,_,_) = y
let proj3_4 (_,_,z,_) = z
let proj4_4 (_,_,_,t) = t

let proj1_5 (x,_,_,_,_) = x
let proj2_5 (_,y,_,_,_) = y
let proj3_5 (_,_,z,_,_) = z
let proj4_5 (_,_,_,t,_) = t
let proj5_5 (_,_,_,_,v) = v

let split3 l =
  List.fold_left (fun (xs, ys, zs) (x, y, z) -> (x :: xs, y :: ys, z :: zs))
    ([],[],[]) l

let isNonef f = fun x -> f x = None

(* FIXME: not tail rec. *)
let rec gcombine l r =
  match l, r with
    | [], r -> [], [], r
    | a :: q, [] -> [], l, []
    | a :: p, b :: q -> let g, rl, rr = gcombine p q in
        (a, b) :: g, rl, rr

(* FIXME: optimize. *)
let list_map_array f l =
  let t = Array.of_list l in
   Array.map f t

let list_iteri f l =
  ignore (List.fold_left (fun acu x -> f acu x; acu+1) 0 l)

let list_mapi f l =
  List.rev (snd (List.fold_left (fun (i,q) x -> (i+1, f i x ::q)) (0,[]) l))

exception NonDisjointCase
exception Failure of exn list

type ('a, 'b) either = Left of 'a | Right of 'b

let one_of e1 e2 =
  let r_e1 = try (Some (e1 ()), None) with ex -> (None, Some ex)
  and r_e2 = try (Some (e2 ()), None) with ex -> (None, Some ex)
  in
    match r_e1, r_e2 with
      | (None, Some ex1), (None, Some ex2) -> raise (Failure [ ex1; ex2 ])
      | (Some v1, None), (Some v2, None)   -> raise NonDisjointCase
      | (Some v1, None), (None, Some ex)   -> Left  (v1, ex)
      | (None, Some ex), (Some v2, None)   -> Right (v2, ex)
      | _                                  -> assert false

let reraise e exn1 exn2 =
  try e () with ex when ex = exn1 -> raise exn2 | ex -> raise ex

let just_try e =
  try Some (e ()) with Not_found -> None

let ( ^^ ) = ( ^ )

let opt_apply f x =
  match f with
    | Some f -> Some (f x)
    | None -> None

let list_foralli f =
  let rec test i = function
      [] -> true
    | a :: q -> if f i a then test (i+1) q else false
  in
    test 0

let list_existsi f =
  let rec test i = function
      [] -> false
    | a :: q -> if f i a then true else test (i+1) q
  in
    test 0

let list_mapi2 f =
  let rec loop i l1 l2 =
    match (l1, l2) with
        [], [] -> []
      | r :: rs, q :: qs -> f i r q :: (loop (i+1) rs qs)
      | _ -> failwith "Invalid arguments for mapi2"
  in
    loop 0

let are_distinct l =
  let rec fold acu = function
      [] -> None
    | x :: q -> if List.mem x acu then Some x else fold (x::acu) q
  in fold [] l

let all_equal l =
  let rec fold acu = function
      [] -> true, acu
    | x :: q -> (match acu with
                     None -> fold (Some x) q
                   | Some y -> if x = y then fold acu q else (false, None))
  in
    fold None l

let list_foldmap f init l =
  let rec aux (ys, accu) = function
    | [] ->
      (List.rev ys, accu)
    | x :: xs ->
      let (y, accu) = f accu x in
      aux (y :: ys, accu) xs
  in
  aux ([], init) l
