(*

 * Std - Additional functions

 * Copyright (C) 2003 Nicolas Cannasse and Markus Mottl

 *

 * This library is free software; you can redistribute it and/or

 * modify it under the terms of the GNU Lesser General Public

 * License as published by the Free Software Foundation; either

 * version 2.1 of the License, or (at your option) any later version,

 * with the special exception on linking described in file LICENSE.

 *

 * This library 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

 * Lesser General Public License for more details.

 *

 * You should have received a copy of the GNU Lesser General Public

 * License along with this library; if not, write to the Free Software

 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

 *)

open ExtBytes

let finally handler f x =

  let r = (

    try

      f x

    with

      e -> handler (); raise e

  ) in

  handler ();

  r

let input_lines ch =

  Enum.from (fun () ->

    try input_line ch with End_of_file -> raise Enum.No_more_elements)

let input_chars ch =

  Enum.from (fun () ->

    try input_char ch with End_of_file -> raise Enum.No_more_elements)

type 'a _mut_list = {

  hd : 'a;

  mutable tl : 'a _mut_list;

}

let input_list ch =

  let _empty = Obj.magic [] in

  let rec loop dst =

    let r = { hd = input_line ch; tl = _empty } in

    dst.tl <- r;

    loop r in

  let r = { hd = Obj.magic(); tl = _empty } in

  try loop r

  with

    End_of_file ->

      Obj.magic r.tl

let buf_len = 8192

let input_all ic =

  let rec loop acc total buf ofs =

    let n = input ic buf ofs (buf_len - ofs) in

    if n = 0 then

      let res = Bytes.create total in

      let pos = total - ofs in

      let _ = Bytes.blit buf 0 res pos ofs in

      let coll pos buf =

        let new_pos = pos - buf_len in

        Bytes.blit buf 0 res new_pos buf_len;

        new_pos in

      let _ = List.fold_left coll pos acc in

      (* [res] doesn't escape and will not be mutated again *)

      Bytes.unsafe_to_string res

    else

      let new_ofs = ofs + n in

      let new_total = total + n in

      if new_ofs = buf_len then

        loop (buf :: acc) new_total (Bytes.create buf_len) 0

      else loop acc new_total buf new_ofs in

  loop [] 0 (Bytes.create buf_len) 0

let input_file ?(bin=false) fname =

  let ch = (if bin then open_in_bin else open_in) fname in

  finally (fun () -> close_in ch) input_all ch

let output_file ~filename ~text =

  let ch = open_out filename in

  finally (fun () -> close_out ch) (output_string ch) text

let print_bool = function

  | true -> print_string "true"

  | false -> print_string "false"

let prerr_bool = function

  | true -> prerr_string "true"

  | false -> prerr_string "false"

let string_of_char c = String.make 1 c

external identity : 'a -> 'a = "%identity"

let rec dump r =

  if Obj.is_int r then

    string_of_int (Obj.magic r : int)

  else (* Block. *)

  let rec get_fields acc = function

    | 0 -> acc

    | n -> let n = n-1 in get_fields (Obj.field r n :: acc) n

  in

    let rec is_list r =

    if Obj.is_int r then

      r = Obj.repr 0 (* [] *)

    else

      let s = Obj.size r and t = Obj.tag r in

      t = 0 && s = 2 && is_list (Obj.field r 1) (* h :: t *)

  in

    let rec get_list r =

    if Obj.is_int r then

      []

    else 

      let h = Obj.field r 0 and t = get_list (Obj.field r 1) in

      h :: t

    in

    let opaque name =

    (* XXX In future, print the address of value 'r'.  Not possible in

    * pure OCaml at the moment.

    *)

    "<" ^ name ^ ">"

    in

    let s = Obj.size r and t = Obj.tag r in

    (* From the tag, determine the type of block. *)

  match t with 

  | _ when is_list r ->

    let fields = get_list r in

    "[" ^ String.concat "; " (List.map dump fields) ^ "]"

  | 0 ->

    let fields = get_fields [] s in

    "(" ^ String.concat ", " (List.map dump fields) ^ ")"

  | x when x = Obj.lazy_tag ->

    (* Note that [lazy_tag .. forward_tag] are < no_scan_tag.  Not

    * clear if very large constructed values could have the same

    * tag. XXX *)

    opaque "lazy"

  | x when x = Obj.closure_tag ->

    opaque "closure"

  | x when x = Obj.object_tag ->

    let fields = get_fields [] s in

    let clasz, id, slots =

      match fields with

      | h::h'::t -> h, h', t 

      | _ -> assert false

    in

    (* No information on decoding the class (first field).  So just print

    * out the ID and the slots. *)

    "Object #" ^ dump id ^ " (" ^ String.concat ", " (List.map dump slots) ^ ")"

    | x when x = Obj.infix_tag ->

    opaque "infix"

    | x when x = Obj.forward_tag ->

    opaque "forward"

  | x when x < Obj.no_scan_tag ->

    let fields = get_fields [] s in

    "Tag" ^ string_of_int t ^

    " (" ^ String.concat ", " (List.map dump fields) ^ ")"

  | x when x = Obj.string_tag ->

    "\"" ^ String.escaped (Obj.magic r : string) ^ "\""

  | x when x = Obj.double_tag ->

    string_of_float (Obj.magic r : float)

  | x when x = Obj.abstract_tag ->

    opaque "abstract"

  | x when x = Obj.custom_tag ->

    opaque "custom"

  | x when x = Obj.double_array_tag ->

    let l = ExtList.List.init s (fun i -> string_of_float (Obj.double_field r i)) in

    "[| " ^ String.concat "; " l ^ " |]"

  | _ ->

    opaque (Printf.sprintf "unknown: tag %d size %d" t s)

let dump v = dump (Obj.repr v)

let print v = print_endline (dump v)

let __unique_counter = ref 0

let unique () =

  incr __unique_counter;

  !__unique_counter