(* 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;;
module G = Generic_io;;
open Fragments;;

let output_format = ref G.Asc;;
let input_format = ref None;;
let check = ref false;;
let old = ref false;;

(*** convert *)
let convert fmt ic oc =
  let reader =
    match !input_format with
    | None -> G.in_from_channel ic
    | Some fmt -> G.in_from_channel ~header:false ~fmt ic
  in
  let writer =
    G.out_from_channel ~fmt oc
  in
  while true do
    convert ~reader ~writer ()
  done
;;
(* ***)
(*** convert_old *)
let convert_old fmt ic oc =
  let i = G.in_from_channel ic in
  let o = G.out_from_channel ~fmt oc in
  let rec do_things ?(eat=false) stoppers =
    let t = read_token i in
    if not (t = EOF && eat) then
      write_token o t;
    match t with
    | Tag T_List -> do_list (); do_things stoppers
    | Tag T_Array -> do_array (); do_things stoppers
    | Tag T_Record -> do_record (); do_things stoppers
    | Tag T_Sum -> do_sum (); do_things stoppers
    | Tag T_Hashtbl -> do_hashtbl (); do_things stoppers
    | Ident x -> do_things stoppers
    | Tag t ->
        if List.mem t stoppers then
          t
        else
          do_things stoppers
    | t -> do_things stoppers
  and do_sum () =
    let x = read_ident i in
    write_ident o x;
    do_things ~eat:true [T_End]
  and do_array () =
    let m = read_int i in
    write_int o m;
    do_things [T_End]
  and do_record () =
    do_things [T_End]
  and do_hashtbl () =
    let m = read_int i in
    write_int o m;
    do_things [T_End]
  and do_list2 () =
    match do_things [T_More;T_End] with
    | T_More -> do_list2 ()
    | T_End -> ()
    | _ -> assert false
  and do_list () =
    match read_tag i with
    | T_More -> do_list2 ()
    | T_End -> ()
    | t -> failwith (sf "Unexpected token <%s> in do_list" (string_of_tag t))
  in
  (*inside "header" (read_this_tag i) T_Data;*)
  ignore (do_things [T_Stop_data])
;;
(* ***)
(*** check_channel *)
let check_channel ic =
  let indent = ref 0 in
  let put_indent () =
    for i = 1 to !indent do
      Printf.printf "  "
    done
  in
  let inside what f x =
    put_indent ();
    Printf.printf "{\n";
    try
      incr indent;
      let z = f x in
      decr indent;
      put_indent ();
      Printf.printf "}\n";
      z
    with
    | y ->
        Printf.printf "While %s:\n%!" what;
        raise y
  in
  let error msg =
    Printf.printf "Error: %s\n%!" msg;
    raise Exit
  in
  let i = G.in_from_channel ic in
  let rec do_things stoppers =
    let t = read_token i in
    put_indent ();
    Printf.printf "<%s>\n" (string_of_token t);
    match t with
    | Tag T_List -> inside "list" do_list (); do_things stoppers
    | Tag T_Array -> inside "array" do_array (); do_things stoppers
    | Tag T_Record -> inside "record" do_record (); do_things stoppers
    | Tag T_Sum -> inside "sum" do_sum (); do_things stoppers
    | Tag T_Hashtbl -> inside "hashtbl" do_hashtbl (); do_things stoppers
    | Ident x ->
        put_indent ();
        Printf.printf "%s:\n" x;
        do_things stoppers
    | Tag t ->
        if List.mem t stoppers then
          t
        else
          do_things stoppers
    | t -> do_things stoppers
  and do_sum () =
    let x = read_ident i in
    put_indent ();
    Printf.printf "|%s\n" x;
    do_things [T_End]
  and do_array () =
    let m = read_int i in
    do_things [T_End]
  and do_record () =
    do_things [T_End]
  and do_hashtbl () =
    let m = read_int i in
    do_things [T_End]
  and do_list2 () =
    match do_things [T_More;T_End] with
    | T_More -> do_list2 ()
    | T_End -> ()
    | _ -> assert false
  and do_list () =
    match read_tag i with
    | T_More -> do_list2 ()
    | T_End -> ()
    | t -> error (sf "Unexpected token <%s> in do_list" (string_of_tag t))
  in
  (*inside "header" (read_this_tag i) T_Data;*)
  ignore (do_things [T_Stop_data])
;;
(* ***)
(*** spec *)
let spec = [
  "-check", Arg.Set check, " Do some syntactic checks.";
  "-old",  Arg.Set old, " Convert from old format.";
  "-ifmt", Arg.String
    begin fun fmt ->
      try
        input_format := Some(G.id_to_format fmt)
      with
      | G.Unknown_format ->
          Printf.eprintf "Unknown format %S.  Available formats: %s.\n%!"
            fmt (String.concat " " (List.map (fun (_,y) -> y) G.format_list));
          exit 1
    end,
    " Set input format.";
  "-fmt", Arg.String
    begin fun fmt ->
      try
        output_format := G.id_to_format fmt
      with
      | G.Unknown_format ->
          Printf.eprintf "Unknown format %S.  Available formats: %s.\n%!"
            fmt (String.concat " " (List.map (fun (_,y) -> y) G.format_list));
          exit 1
    end,
    " Set output format."
];;
(* ***)
(*** main *)
let _ =
  Arg.parse
    spec
    begin fun x ->
      Printf.eprintf "Extraneous argument %S.\n%!" x;
      exit 1
    end
    (Printf.sprintf "Usage: %s [-fmt format] < infile > outfile" (Filename.basename Sys.argv.(0)));
  if !check then
    check_channel stdin
  else
    if !old then
      convert_old !output_format stdin stdout
    else
      convert !output_format stdin stdout
;;
(* ***)
