(* File: sexp.ml

    Copyright (C) 2005-

      Jane Street Holding, LLC
      Author: Markus Mottl
      email: mmottl@janestcapital.com
      WWW: http://www.janestcapital.com/ocaml

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

   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
*)

(* Sexp: Module for handling S-expressions (I/O, etc.) *)

open Format

include Type

(* Default indentation level for human-readable conversions *)

let default_indent = ref 2


(* Scan functions *)

let scan_sexp ?buf lexbuf = Parser.sexp (Lexer.main ?buf) lexbuf
let scan_sexps ?buf lexbuf = Parser.sexps (Lexer.main ?buf) lexbuf

let load_sexp file =
  let chan = open_in file in
  try
    let sexp = scan_sexp (Lexing.from_channel chan) in
    close_in chan;
    sexp
  with e ->
    close_in chan;
    raise e

let load_sexps file =
  let chan = open_in file in
  try
    let sexps = scan_sexps (Lexing.from_channel chan) in
    close_in chan;
    sexps
  with e ->
    close_in chan;
    raise e

let get_main_buf buf =
  let buf =
    match buf with
    | None -> Buffer.create 64
    | Some buf -> buf in
  Lexer.main ~buf

let scan_fold_sexps ?buf ~f ~init lexbuf =
  let main = get_main_buf buf in
  let rec loop acc =
    match Parser.sexp_opt main lexbuf with
    | None -> acc
    | Some sexp -> loop (f sexp acc) in
  loop init

let scan_iter_sexps ?buf ~f lexbuf =
  let main = get_main_buf buf in
  let rec loop () =
    match Parser.sexp_opt main lexbuf with
    | None -> ()
    | Some sexp -> f sexp; loop () in
  loop ()

let scan_cnv_sexps ?buf ~f lexbuf =
  let coll sexp acc = f sexp :: acc in
  List.rev (scan_fold_sexps ?buf ~f:coll ~init:[] lexbuf)


(* Escaping of strings used as atoms in S-expressions *)

let is_special_char c =
  c <= ' ' || c = '"' || c = '(' || c = ')' || c = ';' || c = '\\'

let must_escape str =
  let len = String.length str in
  len = 0 ||
    let rec loop ix = is_special_char str.[ix] || ix > 0 && loop (ix - 1) in
    loop (len - 1)

let maybe_esc_str str =
  if must_escape str then
    let estr = String.escaped str in
    let elen = String.length estr in
    let res = String.create (elen + 2) in
    String.blit estr 0 res 1 elen;
    res.[0] <- '"';
    res.[elen + 1] <- '"';
    res
  else str

let pp_maybe_esc_str ppf str = pp_print_string ppf (maybe_esc_str str)


(* Output of S-expressions to formatters *)

let rec pp_hum_indent indent ppf = function
  | Atom str -> pp_maybe_esc_str ppf str
  | List (h :: t) ->
      pp_open_box ppf indent;
      pp_print_string ppf "(";
      pp_hum_indent indent ppf h;
      pp_hum_rest indent ppf t
  | List [] -> pp_print_string ppf "()"

and pp_hum_rest indent ppf = function
  | h :: t ->
      pp_print_space ppf ();
      pp_hum_indent indent ppf h;
      pp_hum_rest indent ppf t
  | [] ->
      pp_print_string ppf ")";
      pp_close_box ppf ()

let rec pp_mach_internal may_need_space ppf = function
  | Atom str ->
      let str' = maybe_esc_str str in
      let new_may_need_space = str' == str in
      if may_need_space && new_may_need_space then pp_print_string ppf " ";
      pp_print_string ppf str';
      new_may_need_space
  | List (h :: t) ->
      pp_print_string ppf "(";
      let may_need_space = pp_mach_internal false ppf h in
      pp_mach_rest may_need_space ppf t;
      false
  | List [] -> pp_print_string ppf "()"; false

and pp_mach_rest may_need_space ppf = function
  | h :: t ->
      let may_need_space = pp_mach_internal may_need_space ppf h in
      pp_mach_rest may_need_space ppf t
  | [] -> pp_print_string ppf ")"

let pp_hum ppf sexp = pp_hum_indent !default_indent ppf sexp

let pp_mach ppf sexp = ignore (pp_mach_internal false ppf sexp)
let pp = pp_mach


(* Buffer conversions *)

let to_buffer_hum ?(buf = Buffer.create 4096) ?(indent = !default_indent) sexp =
  Format.bprintf buf "%a@?" (pp_hum_indent indent) sexp;
  buf

let to_buffer_mach ?(buf = Buffer.create 4096) sexp =
  let rec loop may_need_space = function
    | Atom str ->
        let str' = maybe_esc_str str in
        let new_may_need_space = str' == str in
        if may_need_space && new_may_need_space then Buffer.add_char buf ' ';
        Buffer.add_string buf str';
        new_may_need_space
    | List (h :: t) ->
        Buffer.add_char buf '(';
        let may_need_space = loop false h in
        loop_rest may_need_space t;
        false
    | List [] -> Buffer.add_string buf "()"; false
  and loop_rest may_need_space = function
    | h :: t ->
        let may_need_space = loop may_need_space h in
        loop_rest may_need_space t
    | [] -> Buffer.add_char buf ')' in
  ignore (loop false sexp);
  buf

let to_buffer = to_buffer_mach


(* Output of S-expressions to I/O-channels *)

let output_hum oc sexp =
  let buf = to_buffer_hum sexp in
  Buffer.output_buffer oc buf

let output_hum_indent indent oc sexp =
  let buf = to_buffer_hum ~indent sexp in
  Buffer.output_buffer oc buf

let output_mach oc sexp =
  let buf = to_buffer_mach sexp in
  Buffer.output_buffer oc buf

let output = output_mach


(* String conversions *)

let of_string str =
  let lexbuf = Lexing.from_string str in
  Parser.sexp Lexer.main lexbuf

let to_string_hum ?indent sexp =
  let buf = to_buffer_hum ?indent sexp in
  Buffer.contents buf

let to_string_mach sexp =
  let buf = to_buffer_mach sexp in
  Buffer.contents buf

let to_string = to_string_mach


(* Utilities for automated type conversions *)

let unit = List []

external sexp_of_t : t -> t = "%identity"
external t_of_sexp : t -> t = "%identity"