(* 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/>. *)

exception Error of string;;

let sf = Printf.sprintf;;

(*** tag *)
type tag =
| T_LParen
| T_RParen
| T_LBrack
| T_RBrack
| T_LBrace
| T_RBrace
| T_Equal
| T_Comma
| T_Semicolon
| T_Array
| T_Hashtbl
| T_Set
;;
(* ***)
(*** tags *)
let tags = [
  T_LParen;
  T_RParen;
  T_LBrack;
  T_RBrack;
  T_LBrace;
  T_RBrace;
  T_Equal;
  T_Comma;
  T_Semicolon;
  T_Array;
  T_Hashtbl;
  T_Set;
];;
(* ***)
(*** string_of_tag *)
let string_of_tag = function
| T_LParen      -> "("
| T_RParen      -> ")"
| T_LBrack      -> "["
| T_RBrack      -> "]"
| T_LBrace      -> "{"
| T_RBrace      -> "}"
| T_Equal       -> "="
| T_Comma       -> ","
| T_Semicolon   -> ";"
| T_Array       -> "array"
| T_Hashtbl     -> "hash"
| T_Set         -> "set"
;;
(* ***)
let reserved_words = ["array";"hash";"set"];;
let is_word_reserved x = List.mem x reserved_words;;
(*** tag_of_string *)
let tag_of_string = function
| "(" -> T_LParen
| ")" -> T_RParen
| "[" -> T_LBrack
| "]" -> T_RBrack
| "{" -> T_LBrace
| "}" -> T_RBrace
| "=" -> T_Equal
| "," -> T_Comma
| ";" -> T_Semicolon
| "array" -> T_Array
| "hash" -> T_Hashtbl
| "set" -> T_Set
| x -> raise (Error(sf "Unknown tag %S" x))
;;
(* ***)
(*** is_tag_voluminous *)
let is_tag_voluminous = function
| T_LParen -> false
| T_RParen -> false
| T_LBrack -> false
| T_RBrack -> false
| T_LBrace -> false
| T_RBrace -> false
| T_Equal -> false
| T_Comma -> false
| T_Semicolon -> false
| T_Array -> true
| T_Hashtbl -> true
| T_Set -> true
;;
(* ***)
(*** int_of_tag *)
let int_of_tag = function
| T_LParen -> 0
| T_RParen -> 1
| T_LBrack -> 2
| T_RBrack -> 3
| T_LBrace -> 4
| T_RBrace -> 5
| T_Equal -> 6
| T_Comma -> 7
| T_Semicolon -> 8
| T_Array -> 9
| T_Hashtbl -> 10
| T_Set -> 11
;;
(* ***)
(*** tag_of_int *)
let tag_of_int = function
| 0 -> T_LParen
| 1 -> T_RParen
| 2 -> T_LBrack
| 3 -> T_RBrack
| 4 -> T_LBrace
| 5 -> T_RBrace
| 6 -> T_Equal
| 7 -> T_Comma
| 8 -> T_Semicolon
| 9 -> T_Array
| 10 -> T_Hashtbl
| 11 -> T_Set
| x -> raise (Error(sf "Unknown tag %d" x))
;;
(* ***)
(*** is_start_tag *)
let is_start_tag = function
| T_LParen | T_LBrack | T_LBrace -> true
| _ -> false
;;
(* ***)
(*** is_end_tag *)
let is_end_tag = function
| T_RParen | T_RBrack | T_RBrace -> true
| _ -> false
;;
(* ***)
let max_tag = 32;;

(*** token *)
type token =
| Bool of bool
| Char of char
| Int of int
| Int64 of int64
| Float of float
| String of string
| Tag of tag
| Field of string
| Constructor of string
| EOF
;;
(* ***)
(*** string_of_token *)
let string_of_token = function
| Bool b         -> sf "Bool(%b)" b
| Char c         -> sf "Char(%C)" c
| Int d          -> sf "Int(%d)" d
| Int64 d        -> sf "Int(%Ld)" d
| Float f        -> sf "Float(%f)" f
| String s       -> sf "String(%S)" s
| Tag x          -> sf "Tag(%S)" (string_of_tag x)
| Field x        -> sf "Field(%S)" x
| Constructor x  -> sf "Constructor(%S)" x
| EOF            -> "EOF"
;;
(* ***)

(*** io_in *)
type io_in = {
  mutable io_lost : bool;
  io_peek_token : (unit -> token);
  io_read_token : (unit -> token);
  io_drop_token : (unit -> unit);
  mutable io_finish : (unit -> unit)
}
(* ***)
(*** io_out *)
type io_out = {
  io_write_token : (token -> unit);
  io_flush : (unit -> unit)
};;
(* ***)

(*** drop_token *)
let drop_token i = i.io_drop_token ();;
(* ***)
(*** peek_token *)
let peek_token i = i.io_peek_token ();;
(* ***)
(*** read_token *)
let read_token i = i.io_read_token ();;
(* ***)
(*** read_tag *)
let read_tag i =
  match read_token i with
  | Tag tag -> tag
  | x -> raise (Error(sf "Expecting tag got %s" (string_of_token x)))
;;
(* ***)
(*** read_this_tag *)
let read_this_tag i tag =
  let tag' = read_tag i in
  if tag = tag' then
    ()
  else
    raise (Error(sf "Expecting tag <%s> got <%s>"
                    (string_of_tag tag)
                    (string_of_tag tag')))
;;
(* ***)
(*** start *)
let start i = ();; (* read_this_tag i T_Data;; XXX *)
(* ***)
(*** default_finish *)
let default_finish i () = ();; (* read_this_tag i T_Stop_data;; *)
(* ***)
(*** create_io_in *)
let create_io_in ~read_token ~peek_token ?finish () =
  let i =
    { io_lost = false;
      io_read_token = read_token;
      io_drop_token = (fun i -> ignore (read_token i));
      io_peek_token = peek_token;
      io_finish = ignore }
  in
  i.io_finish <-
    begin
      match finish with
      | None -> default_finish i
      | Some f -> f i
    end;
  start i;
  i
;;
(* ***)
(*** finish *)
let finish i = i.io_finish ();;
(* ***)
(*** read_int *)
let read_int i =
  match read_token i with
  | Int x -> x
  | x -> raise (Error(sf "Expecting int got %s" (string_of_token x)))
;;
(* ***)
(*** read_int64 *)
let read_int64 i =
  match read_token i with
  | Int64 x -> x
  | x -> raise (Error(sf "Expecting int64 got %s" (string_of_token x)))
;;
(* ***)
(*** read_float *)
let read_float i =
  match read_token i with
  | Float x -> x
  | x -> raise (Error(sf "Expecting float got %s" (string_of_token x)))
;;
(* ***)
(*** read_bool *)
let read_bool i =
  match read_token i with
  | Bool x -> x
  | x -> raise (Error(sf "Expecting bool got %s" (string_of_token x)))
;;
(* ***)
(*** read_char *)
let read_char i =
  match read_token i with
  | Char x -> x
  | x -> raise (Error(sf "Expecting char got %s" (string_of_token x)))
;;
(* ***)
(*** read_constructor *)
let read_constructor i =
  match read_token i with
  | Constructor x -> x
  | x -> raise (Error(sf "Expecting constructor got %s" (string_of_token x)))
;;
(* ***)
(*** read_field *)
let read_field i =
  match read_token i with
  | Field x -> x
  | x -> raise (Error(sf "Expecting field got %s" (string_of_token x)))
;;
(* ***)
(*** read_string *)
let read_string i =
  match read_token i with
  | String x -> x
  | x -> raise (Error(sf "Expecting string got %s" (string_of_token x)))
;;
(* ***)

(*** write_{token,int,char,string,bool,float,tag,ident} *)
let write_token o t = o.io_write_token t;;
let write_int o x    = write_token o (Int x)
let write_int64 o x  = write_token o (Int64 x)
let write_char o x   = write_token o (Char x)
let write_string o x = write_token o (String x)
let write_bool o x   = write_token o (Bool x)
let write_float o x  = write_token o (Float x)
let write_tag o x    = write_token o (Tag x)
let write_field o x  = write_token o (Field x)
let write_constructor o x  = write_token o (Constructor x)
(* ***)
(*** loss *)
let loss i = i.io_lost <- true;;
(* ***)
(*** lost *)
let lost i = i.io_lost;;
(* ***)
(*** create_io_out *)
let create_io_out ~write_token ?(flush=ignore) () =
  { io_write_token = write_token;
    io_flush = flush }
;;
(* ***)
(*** default_flush *)
let default_flush o = ();; (* write_tag o T_Stop_data;; *)
(* ***)
(*** flush *)
let flush o =
  default_flush o;
  o.io_flush ()
;;
(* ***)
