(* Copyright 2005-2007 Berke DURAK, INRIA Rocquencourt.

This file is part of Dose2.

Dose2 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 3 of the License, or
(at your option) any later version.

Dose2 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 program.  If not, see <http://www.gnu.org/licenses/>. *)

open Io;;

exception Unknown_format

(*** file_format *)
type file_format =
| Bin
| Cbn
| Txt
| Asc
;;
(* ***)
(*** format_list *)
let format_list = (* MUST be 3 characters long *)
[ Bin,  "bin";
  Txt,  "txt";
  Asc,  "asc";
  Cbn,  "cbn" ]
;;
(* ***)
(*** format_list_swapped *)
let format_list_swapped = List.map (fun (x,y) -> (y,x)) format_list;;
(* ***)
(*** format_to_id *)
let format_to_id fmt = List.assoc fmt format_list;;
(* ***)
(*** id_to_format *)
let id_to_format id =
  try
    List.assoc id format_list_swapped
  with
  | Not_found -> raise Unknown_format
;;
(* ***)
(*** wrap *)
let wrap x g f =
  begin
    try
      let r = f x in
      g x;
      r
    with
    | z ->
        g x;
        raise z
  end
;;
(* ***)
(*** write_file_format *)
let write_file_format oc fmt =
  output_string oc (format_to_id fmt);
  output_char oc ' '
;;
(* ***)
(*** decode_format *)
let decode_format u c =
  if c <> ' ' && c <> '\n' && c <> '\t' then raise Unknown_format;
  id_to_format u
;;
(* ***)
(*** read_file_format *)
let read_file_format ic =
  let u = String.make 3 ' ' in
  really_input ic u 0 3;
  let c = input_char ic in
  decode_format u c
;;
(* ***)
(*** with_file_out *)
let with_file_out fn f = wrap (open_out_bin fn) close_out f;;
(* ***)
(*** with_file_in *)
let with_file_in fn f = wrap (open_in_bin fn) close_in f;;
(* ***)
(*** in_from_channel *)
let in_from_channel ?(header=true) ?(fmt=Bin) in_channel =
  let fmt =
    if header then
      read_file_format in_channel
    else
      fmt
  in
  match fmt with
  | Asc ->     Ascii_io.in_of_lexbuf ~lexbuf:(Lexing.from_channel in_channel) ()
  | Txt ->     Human_io.in_of_channel ~in_channel ()
  | Bin ->     Binary_io.in_of_channel ~in_channel ()
  | Cbn ->     Binary_io.in_of_channel ~in_channel ~compress:true ()
;;
(* ***)
(*** load_from_channel *)
let load_from_channel ?header ?fmt io in_channel =
  let i = in_from_channel ?header ?fmt in_channel in
  let x = read io i in
  finish i;
  x
(* ***)
(*** out_from_channel *)
let out_from_channel ?(header=true) ?(fmt=Asc) out_channel =
  if header then write_file_format out_channel fmt;
  match fmt with
  | Asc -> Ascii_io.out_of_channel ~out_channel ()
  | Txt -> Human_io.out_of_channel ~indent:true ~out_channel ()
  | Bin -> Binary_io.out_of_channel ~out_channel ()
  | Cbn -> Binary_io.out_of_channel ~out_channel ~compress:true ()
;;
(* ***)
(*** save_to_channel *)
let save_to_channel ?header ?fmt io x out_channel =
  let o = out_from_channel ?header ?fmt out_channel in
  write io x o;
  flush o;
;;
(* ***)
(*** save_to_file *)
let save_to_file ?header ?fmt io x fn = with_file_out fn (save_to_channel ?header ?fmt io x);;
(* ***)
(*** load_from_file *)
let load_from_file io fn = with_file_in fn (load_from_channel io);;
(* ***)
(*** in_from_string *)
let in_from_string ?(header=true) ?(fmt=Bin) ?(offset=0) u =
  let (fmt, offset) =
    if header then
      begin
        if String.length u < offset + 4 then
          raise Unknown_format
        else
          (decode_format (String.sub u offset 3) u.[offset + 3], offset + 4)
      end
    else
      (fmt, offset)
  in
  match fmt with
  | Bin -> Binary_io.in_of_string ~str:u ~offset ()
  | Cbn -> Binary_io.in_of_string ~str:u ~offset ~compress:true ()
  | Asc ->
      let lexbuf = Lexing.from_string u in
      if offset > 0 then
        begin
          lexbuf.Lexing.lex_abs_pos <- offset;
          lexbuf.Lexing.lex_start_pos <- offset;
          lexbuf.Lexing.lex_curr_pos <- offset;
          lexbuf.Lexing.lex_last_pos <- offset;
        end;
      Ascii_io.in_of_lexbuf ~lexbuf ()
  | Txt ->
      let s = Stream.of_string u in
      for i = 1 to 4 do Stream.junk s done;
      Human_io.in_of_stream ~stream:s ()
;;
(* ***)
(*** from_string *)
let from_string ?header ?fmt ?offset io u =
  let i = in_from_string ?header ?fmt ?offset u in
  read io i
;;
(* ***)
(*** to_string *)
let to_string ?(header=true) ?(fmt=Asc) io =
  let fmt_id = (format_to_id fmt)^" " in
  let human () =
    let b = Buffer.create 256 in
    let fmt = Format.formatter_of_buffer b in
    fun x ->
      Format.fprintf fmt "@.";
      Buffer.clear b;
      if header then Buffer.add_string b fmt_id;
      let o = Human_io.out_of_formatter ~formatter:fmt () in
      write io x o;
      flush o;
      Buffer.contents b
  in
  let ascii () =
    let buffer = Buffer.create 256 in
    fun x ->
      Buffer.clear buffer;
      if header then Buffer.add_string buffer fmt_id;
      let o = Ascii_io.out_of_buffer ~buffer () in
      write io x o;
      flush o;
      Buffer.contents buffer
  in
  let bin compress x =
    let (o,get) = Binary_io.out_to_string ~compress () in
    write io x o;
    flush o;
    if header then fmt_id ^ (get ())
    else get ()
  in
  match fmt with
  | Bin -> bin false
  | Cbn -> bin true
  | Asc -> ascii ()
  | Txt -> human ()
;;
(* ***)
