(* Copyright 2012 Tony Garnock-Jones <tonygarnockjones@gmail.com>. *)

(* This file is part of Hop. *)

(* Hop is free software: you can redistribute it and/or modify it *)
(* under the terms of the GNU General Public License as published by the *)
(* Free Software Foundation, either version 3 of the License, or (at your *)
(* option) any later version. *)

(* Hop 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 *)
(* General Public License for more details. *)

(* You should have received a copy of the GNU General Public License *)
(* along with Hop.  If not, see <http://www.gnu.org/licenses/>. *)

type t =
  | Num of float
  | Str of string
  | Arr of t list
  | Rec of (string * t) list
  | Flg of bool
  | Nil

exception Syntax_error

let str s = Str s

let escape_char c =
  match c with
  | '\"' -> Some (fun (s, pos) -> ("\\\"", pos + 1))
  | _ -> None
let escape s = Util.strsub escape_char s

let str_to_string s =
  "\"" ^ escape s ^ "\""

let rec to_string j =
  match j with
    | Num f ->
      if float_of_int (int_of_float f) = f
      then string_of_int (int_of_float f)
      else string_of_float f
    | Str s ->
      str_to_string s
    | Arr js ->
      "[" ^ String.concat "," (List.map to_string js) ^ "]"
    | Rec kvs ->
      "{" ^ String.concat "," (List.map kv_to_string kvs) ^ "}"
    | Flg b ->
      if b then "true" else "false"
    | Nil ->
      "null"
and kv_to_string (k, v) =
  str_to_string k ^ ":" ^ to_string v

let rec pretty_string ?indent:(indent=2) j =
  let rec walk current j =
    match j with
      | Num f ->
	if float_of_int (int_of_float f) = f
	then string_of_int (int_of_float f)
	else string_of_float f
      | Str s ->
	str_to_string s
      | Arr js ->
	"[" ^ String.concat ", " (List.map (walk current) js) ^ "]"
      | Rec [] ->
	"{}"
      | Rec [(k, v)] ->
	"{" ^ str_to_string k ^ ": " ^ walk current v ^ "}"
      | Rec kvs ->
	"{" ^ String.concat "," (List.map (kv_walk (current + indent)) kvs) ^
	  "\n" ^ String.make current ' ' ^ "}"
      | Flg b ->
	if b then "true" else "false"
      | Nil ->
	"null"
  and kv_walk current (k, v) =
    "\n" ^ String.make current ' ' ^ str_to_string k ^ ": " ^ walk current v
  in walk 0 j

let accumulate_utf8 codepoint (acc, len) =
  (* Of course, at the moment, the codepoint is limited to 16 bits... *)
  if codepoint < 0x80 then
    (Char.chr codepoint :: acc, len + 1)
  else if codepoint < 0x800 then
    (Char.chr (0x80 lor (codepoint land 0x3f)) ::
     Char.chr (0xC0 lor ((codepoint lsr 6) land 0x1f)) ::
     acc, len + 2)
  else if codepoint < 0x10000 then
    (Char.chr (0x80 lor (codepoint land 0x3f)) ::
     Char.chr (0x80 lor ((codepoint lsr 6) land 0x3f)) ::
     Char.chr (0xE0 lor ((codepoint lsr 12) land 0xf)) ::
     acc, len + 3)
  else if codepoint < 0x200000 then
    (Char.chr (0x80 lor (codepoint land 0x3f)) ::
     Char.chr (0x80 lor ((codepoint lsr 6) land 0x3f)) ::
     Char.chr (0x80 lor ((codepoint lsr 12) land 0x3f)) ::
     Char.chr (0xF0 lor ((codepoint lsr 18) land 0x7)) ::
     acc, len + 4)
  else if codepoint < 0x4000000 then
    (Char.chr (0x80 lor (codepoint land 0x3f)) ::
     Char.chr (0x80 lor ((codepoint lsr 6) land 0x3f)) ::
     Char.chr (0x80 lor ((codepoint lsr 12) land 0x3f)) ::
     Char.chr (0x80 lor ((codepoint lsr 18) land 0x3f)) ::
     Char.chr (0xF8 lor ((codepoint lsr 24) land 0x3)) ::
     acc, len + 5)
  else
    (Char.chr (0x80 lor (codepoint land 0x3f)) ::
     Char.chr (0x80 lor ((codepoint lsr 6) land 0x3f)) ::
     Char.chr (0x80 lor ((codepoint lsr 12) land 0x3f)) ::
     Char.chr (0x80 lor ((codepoint lsr 18) land 0x3f)) ::
     Char.chr (0x80 lor ((codepoint lsr 24) land 0x3f)) ::
     Char.chr (0xFC lor ((codepoint lsr 30) land 0x1)) ::
     acc, len + 6)

let rec parse_num b (acc, len) =
  match (try Ibuffer.peek_char b with End_of_file -> ' ') with
    | '+' | '-' | 'e' | 'E' | '.'
    | '0' | '1' | '2' | '3' | '4' | '5' | '6' | '7' | '8' | '9' as c ->
      Ibuffer.skip_byte b;
      parse_num b (c :: acc, len + 1)
    | _ ->
      Num (float_of_string (Hopstr.string_of_revlist acc len))

let rec parse_str b (acc, len) =
  match Ibuffer.next_char b with
  | '\"' -> Str (Hopstr.string_of_revlist acc len)
  | '\\' ->
      (match Ibuffer.next_char b with
      | 'b' -> parse_str b (Char.chr 8 :: acc, len + 1)
      | 'f' -> parse_str b (Char.chr 12 :: acc, len + 1)
      | 'n' -> parse_str b (Char.chr 10 :: acc, len + 1)
      | 'r' -> parse_str b (Char.chr 13 :: acc, len + 1)
      | 't' -> parse_str b (Char.chr 9 :: acc, len + 1)
      | 'u' -> parse_str b (accumulate_utf8 (Util.unhex (Bytes.to_string (Ibuffer.next_chars b 4))) (acc, len))
      | c -> parse_str b (c :: acc, len + 1))
  | c -> parse_str b (c :: acc, len + 1)

let rec skip_line_comment b =
  match Ibuffer.next_byte b with
    | 13 (* '\r' *) -> ()
    | 10 (* '\n' *) -> ()
    | _ -> skip_line_comment b

let rec parse_arr b acc =
  Ibuffer.skip_ws b;
  match Ibuffer.peek_char b with
  | ']' -> Ibuffer.skip_byte b; Arr (List.rev acc)
  | ',' -> Ibuffer.skip_byte b; parse_arr b acc
  | _ -> parse_arr b (parse b :: acc)

and parse_rec b acc =
  Ibuffer.skip_ws b;
  match Ibuffer.peek_char b with
  | '}' -> Ibuffer.skip_byte b; Rec (List.rev acc)
  | ',' -> Ibuffer.skip_byte b; parse_rec b acc
  | _ ->
      (match parse b with
      | Str k ->
	  Ibuffer.skip_ws b;
	  (match Ibuffer.next_char b with
	  | ':' -> parse_rec b ((k, parse b) :: acc)
	  | _ -> raise Syntax_error)
      | _ -> raise Syntax_error)

and parse b =
  Ibuffer.skip_ws b;
  match Ibuffer.next_char b with
  | '+' | '-' | '0' | '1' | '2' | '3' | '4' | '5' | '6' | '7' | '8' | '9'
      as c -> parse_num b ([c], 1)
  | '\"' -> parse_str b ([], 0)
  | '[' -> parse_arr b []
  | '{' -> parse_rec b []
  | 't' -> if Ibuffer.next_chars b 3 = (Bytes.of_string "rue") then Flg true else raise Syntax_error
  | 'f' -> if Ibuffer.next_chars b 4 = (Bytes.of_string "alse") then Flg false else raise Syntax_error
  | 'n' -> if Ibuffer.next_chars b 3 = (Bytes.of_string "ull") then Nil else raise Syntax_error
  | '/' -> (* cheating *) skip_line_comment b; parse b
  | _ -> raise Syntax_error

let of_string s = parse (Ibuffer.of_bytes (Bytes.of_string s))

let resp code reason extra_headers j =
  Httpd.resp_generic code reason
    ((Httpd.content_type_header_name, "application/json") :: extra_headers)
    (Httpd.Fixed (Bytes.of_string (to_string j)))
let resp_ok extra_headers j = resp 200 "OK" extra_headers j

let load filename = of_string (Bytes.to_string (Util.file_contents filename))

let get j i =
  match j with
    | Arr js -> List.nth js i
    | _ -> failwith "Json.get"

let find s j =
  match j with
    | Rec kvs -> List.assoc (Bytes.to_string s) kvs
    | _ -> failwith "Json.find"

let set j i v =
  match j with
    | Arr js ->
      (match Util.split_at js i with
	| (prefix, _ :: suffix) -> Arr (prefix @ v :: suffix)
	| _ -> failwith "Json.set")
    | _ ->
      failwith "Json.set"

let add kb v j =
  match j with
    | Rec kvs ->
      let k = Bytes.to_string kb in
      Rec (List.remove_assoc k kvs @ [k, v])
    | _ -> failwith "Json.add"

let push j v =
  match j with
    | Arr js ->
      Arr (js @ [v])
    | _ ->
      failwith "Json.push"

let gpath_adapter = {
  Gpath.get_index = get;
  Gpath.set_index = set;
  Gpath.push = push;
  Gpath.empty_array = (fun () -> Arr []);
  Gpath.get_field = find;
  Gpath.set_field = add;
  Gpath.empty_record = (fun () -> Rec []);
}

let lookup path j = Gpath.run gpath_adapter path j
let lookup_str path_str j = lookup (Gpath.of_string path_str) j

let update path v j = Gpath.set gpath_adapter path v j
let update_str path_str v j = update (Gpath.of_string path_str) v j

let path_fold seed f g j =
  let rec walk seed prefixrev j =
    match j with
      | Arr js ->
	let rec loop seed js =
	  match js with
	    | [] -> seed
	    | j' :: js' -> loop (walk seed (Gpath.Push :: prefixrev) j') js'
	in loop (g (List.rev prefixrev) (Arr []) seed) js
      | Rec kvs ->
	let rec loop seed kvs =
	  match kvs with
	    | [] -> seed
	    | (k, v) :: kvs' -> loop (walk seed (Gpath.Field (Bytes.of_string k) :: prefixrev) v) kvs'
	in loop (g (List.rev prefixrev) (Rec []) seed) kvs
      | other ->
	f (List.rev prefixrev) other seed
  in walk seed [] j

let merge_right under over =
  let ensure_compatible path node j =
    try
      match (Gpath.run gpath_adapter path j, node) with
	| Arr _, Arr _ -> j
	| Rec _, Rec _ -> j
	| _, _ -> Gpath.set gpath_adapter path node j
    with _ ->
      Gpath.set gpath_adapter path node j
  in
  path_fold under update ensure_compatible over

let truish j =
  match j with
    | Num 0.0 -> false
    | Str "" -> false
    | Arr [] -> false
    | Rec [] -> false
    | Flg false -> false
    | Nil -> false
    | _ -> true

let truish_some v =
  match v with
    | Some j -> truish j
    | None -> false