Source file YojsonSafe.ml

(*
Copyright (c) 2010-2012, Martin Jambon
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:

 * Redistributions of source code must retain the above copyright notice,
   this list of conditions and the following disclaimer.
 * Redistributions in binary form must reproduce the above copyright
   notice, this list of conditions and the following disclaimer in the
   documentation and/or other materials provided with the distribution.
 * Neither the name of  nor the names of its contributors may be used to
   endorse or promote products derived from this software without specific
   prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.

----

Vendored!

MlFront_Thunk has its own JSON parsing for nice error handling.
Yojson has pretty printing.

Edits:
- Removed .mli unless necessary, and everything except [Safe] printing.
- Prefixed modules with "Yojson", with aliases using `open struct ... end`.
- Code formatted.
 *)

[@@@warning "-unused-var-strict"]

open struct
  module Common = YojsonCommon
end

(** {3 Type of the JSON tree} *)

type t =
  [ `Null
  | `Bool of bool
  | `Int of int
  | `Intlit of string
  | `Float of float
  | `String of string
  | `Assoc of (string * t) list
  | `List of t list ]
(**
All possible cases defined in Yojson:
- `Null: JSON null
- `Bool of bool: JSON boolean
- `Int of int: JSON number without decimal point or exponent.
- `Intlit of string: JSON number without decimal point or exponent,
	    preserved as a string.
- `Float of float: JSON number, Infinity, -Infinity or NaN.
- `Floatlit of string: JSON number, Infinity, -Infinity or NaN,
	    preserved as a string.
- `String of string: JSON string. Bytes in the range 128-255 are preserved
	    as-is without encoding validation for both reading
	    and writing.
- `Stringlit of string: JSON string literal including the double quotes.
- `Assoc of (string * json) list: JSON object.
- `List of json list: JSON array.
*)

(*
  Note to adventurers: ocamldoc does not support inline comments
  on each polymorphic variant, and cppo doesn't allow to concatenate
  comments, so it would be complicated to document only the
  cases that are preserved by cppo in the type definition.
*)

(* let rec to_basic : t -> Basic.t = function
   | (`Null | `Bool _ | `Int _ | `Float _ | `String _) as x -> x
   | `Intlit s -> `String s
   | `List l -> `List (List.rev (List.rev_map to_basic l))
   | `Assoc l ->
       `Assoc (List.rev (List.rev_map (fun (k, v) -> (k, to_basic v)) l)) *)

let hex n = Char.chr (if n < 10 then n + 48 else n + 87)

let write_special src start stop ob str =
  Buffer.add_substring ob src !start (stop - !start);
  Buffer.add_string ob str;
  start := stop + 1

let write_control_char src start stop ob c =
  Buffer.add_substring ob src !start (stop - !start);
  Buffer.add_string ob "\\u00";
  Buffer.add_char ob (hex (Char.code c lsr 4));
  Buffer.add_char ob (hex (Char.code c land 0xf));
  start := stop + 1

let finish_string src start ob =
  try Buffer.add_substring ob src !start (String.length src - !start)
  with exc ->
    Printf.eprintf "src=%S start=%i len=%i\n%!" src !start
      (String.length src - !start);
    raise exc

let write_string_body ob s =
  let start = ref 0 in
  for i = 0 to String.length s - 1 do
    match s.[i] with
    | '"' -> write_special s start i ob "\\\""
    | '\\' -> write_special s start i ob "\\\\"
    | '\b' -> write_special s start i ob "\\b"
    | '\012' -> write_special s start i ob "\\f"
    | '\n' -> write_special s start i ob "\\n"
    | '\r' -> write_special s start i ob "\\r"
    | '\t' -> write_special s start i ob "\\t"
    | ('\x00' .. '\x1F' | '\x7F') as c -> write_control_char s start i ob c
    | _ -> ()
  done;
  finish_string s start ob

let write_string ob s =
  Buffer.add_char ob '"';
  write_string_body ob s;
  Buffer.add_char ob '"'

let json_string_of_string s =
  let ob = Buffer.create 10 in
  write_string ob s;
  Buffer.contents ob

let write_null ob () = Buffer.add_string ob "null"
let write_bool ob x = Buffer.add_string ob (if x then "true" else "false")
let dec n = Char.chr (n + 48)

let rec write_digits s x =
  if x = 0 then ()
  else
    let d = x mod 10 in
    write_digits s (x / 10);
    Buffer.add_char s (dec (abs d))

let write_int ob x =
  if x > 0 then write_digits ob x
  else if x < 0 then (
    Buffer.add_char ob '-';
    write_digits ob x)
  else Buffer.add_char ob '0'

let json_string_of_int i = string_of_int i

(*
  Ensure that the float is not printed as an int.
  This is not required by JSON, but useful in order to guarantee
  reversibility.
*)
let float_needs_period s =
  try
    for i = 0 to String.length s - 1 do
      match s.[i] with '0' .. '9' | '-' -> () | _ -> raise Exit
    done;
    true
  with Exit -> false

(*
  Guarantees that a sufficient number of digits are printed in order to allow
  reversibility.
*)
let write_float ob x =
  match classify_float x with
  | FP_nan -> Buffer.add_string ob "NaN"
  | FP_infinite ->
      Buffer.add_string ob (if x > 0. then "Infinity" else "-Infinity")
  | _ ->
      let s1 = Printf.sprintf "%.16g" x in
      let s = if float_of_string s1 = x then s1 else Printf.sprintf "%.17g" x in
      Buffer.add_string ob s;
      if float_needs_period s then Buffer.add_string ob ".0"

let write_normal_float_prec significant_figures ob x =
  let sprintf = Printf.sprintf in
  let s =
    match significant_figures with
    | 1 -> sprintf "%.1g" x
    | 2 -> sprintf "%.2g" x
    | 3 -> sprintf "%.3g" x
    | 4 -> sprintf "%.4g" x
    | 5 -> sprintf "%.5g" x
    | 6 -> sprintf "%.6g" x
    | 7 -> sprintf "%.7g" x
    | 8 -> sprintf "%.8g" x
    | 9 -> sprintf "%.9g" x
    | 10 -> sprintf "%.10g" x
    | 11 -> sprintf "%.11g" x
    | 12 -> sprintf "%.12g" x
    | 13 -> sprintf "%.13g" x
    | 14 -> sprintf "%.14g" x
    | 15 -> sprintf "%.15g" x
    | 16 -> sprintf "%.16g" x
    | _ -> sprintf "%.17g" x
  in
  Buffer.add_string ob s;
  if float_needs_period s then Buffer.add_string ob ".0"

let json_string_of_float x =
  let ob = Buffer.create 20 in
  write_float ob x;
  Buffer.contents ob

let write_float ob x =
  match classify_float x with
  | FP_nan -> Common.json_error "NaN value not allowed in standard JSON"
  | FP_infinite ->
      Common.json_error
        (if x > 0. then "Infinity value not allowed in standard JSON"
        else "-Infinity value not allowed in standard JSON")
  | _ ->
      let s1 = Printf.sprintf "%.16g" x in
      let s = if float_of_string s1 = x then s1 else Printf.sprintf "%.17g" x in
      Buffer.add_string ob s;
      if float_needs_period s then Buffer.add_string ob ".0"

(* to be deprecated in a future release *)
let write_std_float = write_float

(* used by atdgen *)
let write_float_prec significant_figures ob x =
  match classify_float x with
  | FP_nan -> Common.json_error "NaN value not allowed in standard JSON"
  | FP_infinite ->
      Common.json_error
        (if x > 0. then "Infinity value not allowed in standard JSON"
        else "-Infinity value not allowed in standard JSON")
  | _ -> write_normal_float_prec significant_figures ob x

let write_std_float_prec = write_float_prec
let write_intlit = Buffer.add_string
(* let write_floatlit = Buffer.add_string *)
(* let write_stringlit = Buffer.add_string *)

let rec iter2_aux f_elt f_sep x = function
  | [] -> ()
  | y :: l ->
      f_sep x;
      f_elt x y;
      iter2_aux f_elt f_sep x l

let iter2 f_elt f_sep x = function
  | [] -> ()
  | y :: l ->
      f_elt x y;
      iter2_aux f_elt f_sep x l

let f_sep ob = Buffer.add_char ob ','

let rec write_json ob (x : t) =
  match x with
  | `Null -> write_null ob ()
  | `Bool b -> write_bool ob b
  | `Int i -> write_int ob i
  | `Intlit s -> Buffer.add_string ob s
  | `Float f -> write_float ob f
  | `String s -> write_string ob s
  | `Assoc l -> write_assoc ob l
  | `List l -> write_list ob l

and write_assoc ob l =
  let f_elt ob (s, x) =
    write_string ob s;
    Buffer.add_char ob ':';
    write_json ob x
  in
  Buffer.add_char ob '{';
  iter2 f_elt f_sep ob l;
  Buffer.add_char ob '}'

and write_list ob l =
  Buffer.add_char ob '[';
  iter2 write_json f_sep ob l;
  Buffer.add_char ob ']'

let write_t = write_json
let write_std_json = write_json

(* std argument is going to be deprecated *)
let to_buffer ?(suf = "") ?(std = true) ob x =
  write_json ob x;
  Buffer.add_string ob suf

let to_string ?buf ?(len = 256) ?(suf = "") ?std x =
  let ob =
    match buf with
    | None -> Buffer.create len
    | Some ob ->
        Buffer.clear ob;
        ob
  in
  to_buffer ~suf ?std ob x;
  let s = Buffer.contents ob in
  Buffer.clear ob;
  s

let to_channel ?buf ?(len = 4096) ?(suf = "") ?std oc x =
  let ob =
    match buf with
    | None -> Buffer.create len
    | Some ob ->
        Buffer.clear ob;
        ob
  in
  to_buffer ~suf ?std ob x;
  Buffer.output_buffer oc ob;
  Buffer.clear ob

let to_output ?buf ?(len = 4096) ?(suf = "") ?std out x =
  let ob =
    match buf with
    | None -> Buffer.create len
    | Some ob ->
        Buffer.clear ob;
        ob
  in
  to_buffer ~suf ?std ob x;
  (* this requires an int and never uses it. This is done to preserve
     backward compatibility to not break the signatur but can safely
     be changed to require unit in a future compatibility-breaking
     release *)
  let (_ : int) = out#output (Buffer.contents ob) 0 (Buffer.length ob) in
  Buffer.clear ob

let to_file ?len ?std ?(suf = "\n") file x =
  let oc = open_out file in
  try
    to_channel ?len ~suf ?std oc x;
    close_out oc
  with e ->
    close_out_noerr oc;
    raise e

let seq_to_buffer ?(suf = "\n") ?std ob st =
  Seq.iter (to_buffer ~suf ?std ob) st

let seq_to_string ?buf ?(len = 256) ?(suf = "\n") ?std st =
  let ob =
    match buf with
    | None -> Buffer.create len
    | Some ob ->
        Buffer.clear ob;
        ob
  in
  seq_to_buffer ~suf ?std ob st;
  let s = Buffer.contents ob in
  Buffer.clear ob;
  s

let seq_to_channel ?buf ?(len = 2096) ?(suf = "\n") ?std oc seq =
  let ob =
    match buf with
    | None -> Buffer.create len
    | Some ob ->
        Buffer.clear ob;
        ob
  in
  Seq.iter
    (fun json ->
      to_buffer ~suf ?std ob json;
      Buffer.output_buffer oc ob;
      Buffer.clear ob)
    seq

let seq_to_file ?len ?(suf = "\n") ?std file st =
  let oc = open_out file in
  try
    seq_to_channel ?len ~suf ?std oc st;
    close_out oc
  with e ->
    close_out_noerr oc;
    raise e

let rec sort = function
  | `Assoc l ->
      let l = List.rev (List.rev_map (fun (k, v) -> (k, sort v)) l) in
      `Assoc (List.stable_sort (fun (a, _) (b, _) -> String.compare a b) l)
  | `List l -> `List (List.rev (List.rev_map sort l))
  | x -> x

module Pretty = struct
  (*
   Pretty-print JSON data in an attempt to maximize readability.

   1. What fits on one line stays on one line.
   2. What doesn't fit on one line gets printed more vertically so as to not
      exceed a reasonable page width, if possible.

   Arrays containing only simple elements ("atoms") are pretty-printed with
   end-of-line wrapping like ordinary text:

     [
        "hello", "hello", "hello", "hello", "hello", "hello", "hello", "hello",
        "hello", "hello", "hello", "hello", "hello", "hello", "hello", "hello"
     ]

   Other arrays are printed either horizontally or vertically depending
   on whether they fit on a single line:

     [ { "hello": "world" }, { "hello": "world" }, { "hello": "world" } ]

   or

     [
       { "hello": "world" },
       { "hello": "world" },
       { "hello": "world" },
       { "hello": "world" }
     ]
*)

  let pp_list sep ppx out l =
    let pp_sep out () = Format.fprintf out "%s@ " sep in
    Format.pp_print_list ~pp_sep ppx out l

  let is_atom (x : [> t ]) =
    match x with
    | `Null | `Bool _ | `Int _ | `Float _ | `String _ | `Intlit _ | `Floatlit _
    | `Stringlit _
    | `List []
    | `Assoc [] ->
        true
    | `List _ | `Assoc _ -> false

  let is_atom_list l = List.for_all is_atom l

  (*
   inside_box: indicates that we're already within a box that imposes
   a certain style and we shouldn't create a new one. This is used for
   printing field values like this:

     foo: [
       bar
     ]

   rather than something else like

     foo:
       [
         bar
       ]
*)
  let rec format ~inside_box (out : Format.formatter) (x : t) : unit =
    match x with
    | `Null -> Format.pp_print_string out "null"
    | `Bool x -> Format.pp_print_bool out x
    | `Int x -> Format.pp_print_string out (json_string_of_int x)
    | `Float x -> Format.pp_print_string out (json_string_of_float x)
    | `String s -> Format.pp_print_string out (json_string_of_string s)
    | `Intlit s -> Format.pp_print_string out s
    | `List [] -> Format.pp_print_string out "[]"
    | `List l ->
        if not inside_box then Format.fprintf out "@[<hv2>";
        if is_atom_list l then
          (* use line wrapping like we would do for a paragraph of text *)
          Format.fprintf out "[@;<1 0>@[<hov>%a@]@;<1 -2>]"
            (pp_list "," (format ~inside_box:false))
            l
        else
          (* print the elements horizontally if they fit on the line,
             otherwise print them in a column *)
          Format.fprintf out "[@;<1 0>@[<hv>%a@]@;<1 -2>]"
            (pp_list "," (format ~inside_box:false))
            l;
        if not inside_box then Format.fprintf out "@]"
    | `Assoc [] -> Format.pp_print_string out "{}"
    | `Assoc l ->
        if not inside_box then Format.fprintf out "@[<hv2>";
        Format.fprintf out "{@;<1 0>%a@;<1 -2>}" (pp_list "," format_field) l;
        if not inside_box then Format.fprintf out "@]"

  and format_field out (name, x) =
    Format.fprintf out "@[<hv2>%s: %a@]"
      (json_string_of_string name)
      (format ~inside_box:true) x

  (* [std] argument to be deprecated *)
  let pp ?(std = true) out x =
    Format.fprintf out "@[<hv2>%a@]" (format ~inside_box:true) (x :> t)

  let to_string ?std x = Format.asprintf "%a" (pp ?std) x

  let to_channel ?std oc x =
    let fmt = Format.formatter_of_out_channel oc in
    Format.fprintf fmt "%a@?" (pp ?std) x
end

let rec pp fmt = function
  | `Null -> Format.pp_print_string fmt "`Null"
  | `Bool x ->
      Format.fprintf fmt "`Bool (@[<hov>";
      Format.fprintf fmt "%B" x;
      Format.fprintf fmt "@])"
  | `Int x ->
      Format.fprintf fmt "`Int (@[<hov>";
      Format.fprintf fmt "%d" x;
      Format.fprintf fmt "@])"
  | `Intlit x ->
      Format.fprintf fmt "`Intlit (@[<hov>";
      Format.fprintf fmt "%S" x;
      Format.fprintf fmt "@])"
  | `Float x ->
      Format.fprintf fmt "`Float (@[<hov>";
      Format.fprintf fmt "%F" x;
      Format.fprintf fmt "@])"
  | `String x ->
      Format.fprintf fmt "`String (@[<hov>";
      Format.fprintf fmt "%S" x;
      Format.fprintf fmt "@])"
  | `Assoc xs ->
      Format.fprintf fmt "`Assoc (@[<hov>";
      Format.fprintf fmt "@[<2>[";
      ignore
        (List.fold_left
           (fun sep (key, value) ->
             if sep then Format.fprintf fmt ";@ ";
             Format.fprintf fmt "(@[";
             Format.fprintf fmt "%S" key;
             Format.fprintf fmt ",@ ";
             pp fmt value;
             Format.fprintf fmt "@])";
             true)
           false xs);
      Format.fprintf fmt "@,]@]";
      Format.fprintf fmt "@])"
  | `List xs ->
      Format.fprintf fmt "`List (@[<hov>";
      Format.fprintf fmt "@[<2>[";
      ignore
        (List.fold_left
           (fun sep x ->
             if sep then Format.fprintf fmt ";@ ";
             pp fmt x;
             true)
           false xs);
      Format.fprintf fmt "@,]@]";
      Format.fprintf fmt "@])"

let show x = Format.asprintf "%a" pp x

let rec equal a b =
  match (a, b) with
  | `Null, `Null -> true
  | `Bool a, `Bool b -> a = b
  | `Int a, `Int b -> a = b
  | `Intlit a, `Intlit b -> a = b
  | `Float a, `Float b -> a = b
  | `String a, `String b -> a = b
  | `Assoc xs, `Assoc ys -> (
      let compare_keys (key, _) (key', _) = String.compare key key' in
      let xs = List.stable_sort compare_keys xs in
      let ys = List.stable_sort compare_keys ys in
      match
        List.for_all2
          (fun (key, value) (key', value') ->
            match key = key' with false -> false | true -> equal value value')
          xs ys
      with
      | result -> result
      | exception Invalid_argument _ ->
          (* the lists were of different lengths, thus unequal *)
          false)
  | `List xs, `List ys -> (
      match List.for_all2 equal xs ys with
      | result -> result
      | exception Invalid_argument _ ->
          (* the lists were of different lengths, thus unequal *)
          false)
  | _ -> false

let pretty_print ?std out x = Pretty.pp ?std out x
let pretty_to_string ?std x = Pretty.to_string ?std x
let pretty_to_channel ?std oc x = Pretty.to_channel ?std oc x

module Util = struct
  exception Type_error of string * t

  let typeof = function
    | `Assoc _ -> "object"
    | `Bool _ -> "bool"
    | `Float _ -> "float"
    | `Int _ -> "int"
    | `List _ -> "array"
    | `Null -> "null"
    | `String _ -> "string"
    | `Intlit _ -> "intlit"
    | `Floatlit _ -> "floatlit"

  let typerr msg js = raise (Type_error (msg ^ typeof js, js))

  exception Undefined of string * t

  let assoc name obj = try List.assoc name obj with Not_found -> `Null

  let member name = function
    | `Assoc obj -> assoc name obj
    | js -> typerr ("Can't get member '" ^ name ^ "' of non-object type ") js

  let rec path l obj =
    match l with
    | [] -> Some obj
    | key :: l ->
    match obj with
    | `Assoc assoc -> (
        match List.assoc key assoc with
        | obj -> path l obj
        | exception Not_found -> None)
    | _ -> None

  let index i = function
    | `List l as js ->
        let len = List.length l in
        let wrapped_index = if i < 0 then len + i else i in
        if wrapped_index < 0 || wrapped_index >= len then
          raise (Undefined ("Index " ^ string_of_int i ^ " out of bounds", js))
        else List.nth l wrapped_index
    | js ->
        typerr ("Can't get index " ^ string_of_int i ^ " of non-array type ") js

  let map f = function
    | `List l -> `List (List.map f l)
    | js -> typerr "Can't map function over non-array type " js

  let to_assoc = function
    | `Assoc obj -> obj
    | js -> typerr "Expected object, got " js

  let to_option f = function `Null -> None | x -> Some (f x)
  let to_bool = function `Bool b -> b | js -> typerr "Expected bool, got " js

  let to_bool_option = function
    | `Bool b -> Some b
    | `Null -> None
    | js -> typerr "Expected bool or null, got " js

  let to_number = function
    | `Int i -> float i
    | `Float f -> f
    | js -> typerr "Expected number, got " js

  let to_number_option = function
    | `Int i -> Some (float i)
    | `Float f -> Some f
    | `Null -> None
    | js -> typerr "Expected number or null, got " js

  let to_float = function
    | `Float f -> f
    | js -> typerr "Expected float, got " js

  let to_float_option = function
    | `Float f -> Some f
    | `Null -> None
    | js -> typerr "Expected float or null, got " js

  let to_int = function `Int i -> i | js -> typerr "Expected int, got " js

  let to_int_option = function
    | `Int i -> Some i
    | `Null -> None
    | js -> typerr "Expected int or null, got " js

  let to_list = function `List l -> l | js -> typerr "Expected array, got " js

  let to_string = function
    | `String s -> s
    | js -> typerr "Expected string, got " js

  let to_string_option = function
    | `String s -> Some s
    | `Null -> None
    | js -> typerr "Expected string or null, got " js

  let convert_each f = function
    | `List l -> List.map f l
    | js -> typerr "Can't convert each element of non-array type " js

  let rec rev_filter_map f acc l =
    match l with
    | [] -> acc
    | x :: tl ->
    match f x with
    | None -> rev_filter_map f acc tl
    | Some y -> rev_filter_map f (y :: acc) tl

  let filter_map f l = List.rev (rev_filter_map f [] l)

  let rec rev_flatten acc l =
    match l with
    | [] -> acc
    | x :: tl ->
    match x with
    | `List l2 -> rev_flatten (List.rev_append l2 acc) tl
    | _ -> rev_flatten acc tl

  let flatten l = List.rev (rev_flatten [] l)

  let filter_index i l =
    filter_map
      (function
        | `List l -> ( try Some (List.nth l i) with _ -> None) | _ -> None)
      l

  let filter_list l = filter_map (function `List l -> Some l | _ -> None) l

  let filter_member k l =
    filter_map
      (function
        | `Assoc l -> ( try Some (List.assoc k l) with _ -> None) | _ -> None)
      l

  let filter_assoc l = filter_map (function `Assoc l -> Some l | _ -> None) l
  let filter_bool l = filter_map (function `Bool x -> Some x | _ -> None) l
  let filter_int l = filter_map (function `Int x -> Some x | _ -> None) l
  let filter_float l = filter_map (function `Float x -> Some x | _ -> None) l

  let filter_number l =
    filter_map
      (function `Int x -> Some (float x) | `Float x -> Some x | _ -> None)
      l

  let filter_string l =
    filter_map (function `String x -> Some x | _ -> None) l

  let keys o = to_assoc o |> List.map (fun (key, _) -> key)
  let values o = to_assoc o |> List.map (fun (_, value) -> value)

  let combine (first : t) (second : t) =
    match (first, second) with
    | `Assoc a, `Assoc b -> (`Assoc (a @ b) : t)
    | a, b -> raise (Invalid_argument "Expected two objects, check inputs")
end