(* 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;;
open Fragments;;

let sf = Printf.sprintf;;

(*** G *)
module G =
  struct
    include Genlex
    (*** string_of_token *)
    let string_of_token = function
    | Ident x  -> sf "Ident(%S)" x
    | Int d    -> sf "Int(%d)" d
    | Float f  -> sf "Float(%f)" f
    | Kwd x    -> sf "Kwd(%S)" x
    | String s -> sf "String(%S)" s
    | Char c   -> sf "Char(%C)" c
    (* ***)
  end
;;
(* ***)
(*** tag_list *)
let tag_list =
  ["true";"false";"nan"] @
  (List.map string_of_tag tags)
;;
(* ***)
(*** in_of_stream *)
let in_of_stream ~stream () =
  let g = G.make_lexer tag_list stream in
  let next () =
    try
      Stream.next g
    with
    | Stream.Failure ->
        Stream.empty g;
        raise End_of_file
  in
  (*let peek () = Stream.peek g in
  let junk () = Stream.junk g in*)
  let convert = function
    | G.Ident x -> 
      begin
        match x.[0] with
        | 'A'..'Z' ->
            Constructor x
        | _ ->
            Field x
      end
    | G.Int x       -> Int x
    | G.Char x      -> Char x
    | G.Float x     -> Float x
    | G.String x    -> String x
    | G.Kwd "true"  -> Bool true
    | G.Kwd "false" -> Bool false
    | G.Kwd x       -> Tag(tag_of_string x)
  in
  create_io_in
    ~peek_token:
      begin fun () ->
        match
          Stream.peek g
        with
        | None -> raise End_of_file
        | Some t -> convert t
      end
    ~read_token:
      begin fun () -> convert (next ()) end
      ()
;;
(* ***)
(*** in_of_channel *)
let in_of_channel ~in_channel () =
  in_of_stream ~stream:(Stream.of_channel in_channel) ()
;;
(* ***)
(*** out_of_formatter *)
let out_of_formatter ~formatter ?(indent=false) () =
  let fp = Format.fprintf in
  let fmt = formatter in
  let space = ref false in
  let string_of_tag = string_of_tag in
  create_io_out
    ~write_token:
      begin function
      | Int x -> fp fmt "@ %d" x
      | Int64 x -> fp fmt "@ %Ld" x
      | Char x -> fp fmt "@ %C" x
      | String x -> fp fmt "@ %S" x
      | Float x -> fp fmt "@ %F" x
      | Bool x -> fp fmt "@ %b" x
      | Tag x ->
          if indent && is_end_tag x then fp fmt "@]";
          if !space then
            fp fmt "@ %s" (string_of_tag x)
          else
            fp fmt "%s" (string_of_tag x);
          space := true;
          if indent && is_start_tag x then fp fmt "@["
      | Constructor x ->
          let y = String.copy x in
          y.[0] <- Char.uppercase x.[0];
          fp fmt "@ %s" y
      | Field x -> fp fmt "@ %s" x
      | EOF -> ()
      end
    ~flush:
      begin fun () ->
        fp fmt "@."
      end
    ()
;;
(* ***)
(*** condense_formatter *)
let condense_formatter fmt =
  let (out, flush, newline, spaces) = Format.pp_get_all_formatter_output_functions fmt () in
  let fmt' = Format.make_formatter out flush in
  Format.pp_set_all_formatter_output_functions fmt'
    ~out
    ~flush
    ~newline:(fun _ -> ())
    ~spaces:(function 0 -> () | _ -> out " " 0 1);
  fmt'
;;
(* ***)
(*** out_of_channel *)
let out_of_channel ?(condensed=false) ~out_channel =
  let fmt = (Format.formatter_of_out_channel out_channel) in
  let formatter =
    if condensed then
      condense_formatter fmt
    else
      fmt
  in
  out_of_formatter ~formatter
;;
(* ***)
