Source

tiny_json_conv / lib / json_conv.ml

open Printf
open Tiny_json
open Json
open Meta_conv.Open

(* encoders ***************************************************************)

let errorf fmt =
  Printf.ksprintf (fun s -> failwith (Printf.sprintf "Json_conv: %s" s)) fmt

include Meta_conv.Coder.Make(struct 
    
  type target = Json.t

  let format = Json.format

  module Constr = struct
    let tuple ts       = Array ts
    let variant tag = function
      | [] -> String tag
      | ts -> Object [tag, Array ts]
    let record tag_ts  = Object tag_ts
    let poly_variant = variant
    let object_ = record
  end
  
  module Deconstr = struct
    let tuple = function 
      | Array ts -> ts
      | _ -> errorf "Array expected for tuple"
  
    let variant = function 
      | String tag -> tag, [] 
      | Object [tag, Array ts] -> tag, ts
      | _ -> errorf "Object expected for variant"
  
    let record = function
      | Object alist -> alist
      | _ -> errorf "Object expected for record"
  
    let poly_variant = variant
    let object_ = record
  end
end)

let json_of_int n       = Number (float n)
let json_of_int32 n     = Number (Int32.to_float n)
let json_of_int64 n     = Number (Int64.to_float n)
let json_of_nativeint n = Number (Nativeint.to_float n)
let json_of_char c      = String (String.make 1 c)
let json_of_string s    = String s
let json_of_float n     = Number n
let json_of_list f xs   = Array (List.map f xs)
let json_of_array f xs  = Array (List.map f (Array.to_list xs))
let json_of_bool b      = Bool b
let json_of_lazy_t f v  = f (Lazy.force v)
let json_of_unit ()     = Null
let json_of_option f    = function
  | None -> Null
  | Some v -> f v

(* decoders ***************************************************************)

let errorff fmt = kprintf (fun s -> raise (Failure s)) fmt

let string_of_json = Helper.of_deconstr (function
  | String s -> s
  | _ -> errorf "string_of_json: String expected")

let char_of_json = Helper.of_deconstr (function
  | String s when String.length s = 1 -> s.[0]
  | _ -> errorf "char_of_json: a char expected")

let int_check name min max conv = Helper.of_deconstr (function 
  | Number n -> 
      begin match Helper.integer_of_float min max conv n with
      | `Ok v -> v
      | `Error s -> errorff "%s_of_json: %s" name s
      end
  | _ -> errorff "%s_of_json: Number expected" name)

let int_of_json =
  int_check "int" (float min_int) (float max_int) int_of_float

let int64_of_json =
  let open Int64 in
  int_check "int64" (to_float min_int) (to_float max_int) of_float
      
let int32_of_json =
  let open Int32 in
  int_check "int32" (to_float min_int) (to_float max_int) of_float
      
let nativeint_of_json = 
  let open Nativeint in
  int_check "nativeint" (to_float min_int) (to_float max_int) of_float
      
let float_of_json = Helper.of_deconstr (function
  | Number n -> n
  | _ -> errorf "float_of_json: Number expected")

let bool_of_json = Helper.of_deconstr (function
  | Bool b -> b
  | _ -> errorf "bool_of_json: Bool expected")

let unit_of_json = Helper.of_deconstr (function
  | Null -> ()
  | _ -> errorf "unit_of_json: Null expected")
  
let list_of_json f = 
  Helper.list_of (function Array xs -> Some xs | _ -> None) f

let array_of_json f = 
  Helper.array_of (function Array xs -> Some xs | _ -> None) f

let option_of_json f = Helper.option_of 
  (function Null -> Some None | v -> Some (Some v))
  f

let lazy_t_of_json d = Helper.lazy_t_of (fun e -> raise (Error e)) d
let mc_lazy_t_of_json (d : 'a decoder) = (Helper.mc_lazy_t_of d : ('a, Json.t) mc_lazy_t decoder)

let json_of_mc_fields enc xs = Object (List.map (fun (name, a) -> (name, enc a)) xs)
let mc_fields_of_json dec = Helper.mc_fields_of (function Object js -> Some js | _ -> None) dec