Source

ocaml-bitbucket / json_wrap.ml

module Json = struct
  type t = Json_type.json_type =
      | Object of (string * t) list
      | Array of t list
      | String of string
      | Int of int
      | Float of float
      | Bool of bool
      | Null
end

module Json_conv = struct
  open Printf
  open Meta_conv.Conv
  open Json
  
  (* encoders ***************************************************************)
  
  (* pretty normal. nothing to say specially *)
  
  module Encode = struct
    let tuple ts       = Array ts
    let variant tag = function
      | [] -> String tag
      | ts -> Object [tag, Array ts]
    let record tag_ts  = Object tag_ts
  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 ***************************************************************)
  
  (* complex
  
     Do we really need addresses?
  
  *)
  
  module Decode = Make_Decode_Adrs(struct
    type t = Json.t
  
    let tuple = function 
      | Array ts -> ts
      | _ -> failwith "Array expected for array"
  
    let variant = function 
      | String tag -> tag, [] 
      | Object [tag, Array ts] -> tag, ts
      | _ -> failwith "Object expected for variant"
  
    let record = function
      | Object alist -> alist
      | _ -> failwith "Object expected for record"
  end)
  
  exception Error of Json.t error
  
  type 'a decoder = ('a, Json.t) Meta_conv.Conv.decoder
  
  let errorf v adrs fmt = 
    kprintf (fun s -> `Error (Primitive_decoding_failure s, v, adrs)) fmt
  
  let string_of_json ?(adrs=Address.top) = function
    | String s -> `Ok s
    | v -> errorf v adrs "string_of_json: String expected"
  
  let char_of_json ?(adrs=Address.top) = function
    | String s when String.length s = 1 -> `Ok s.[0]
    | v -> errorf v adrs "char_of_json: a char expected"
  
  let int_check name min max conv ?(adrs=Address.top) v = match v with
    | Number n -> 
        begin match integer_of_float min max conv n with
        | `Ok v -> `Ok v
        | `Error s -> errorf v adrs "%s_of_json: %s" name s
        end
    | _ -> errorf v adrs "%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 ?(adrs=Address.top) = function
    | Number n -> `Ok n
    | n -> errorf n adrs "float_of_json: Number expected"
  
  let bool_of_json ?(adrs=Address.top) = function
    | Bool b -> `Ok b
    | v -> errorf v adrs "bool_of_json: Bool expected"
  
  let unit_of_json ?(adrs=Address.top) = function
    | Null -> `Ok ()
    | v -> errorf v adrs "unit_of_json: Null expected"
    
  let list_of_json f = 
    generic_list_of (function Array xs -> Some xs | _ -> None) f
  
  let array_of_json f = 
    generic_array_of (function Array xs -> Some xs | _ -> None) f
  
  let option_of_json f = generic_option_of 
    (function Null -> true | _ -> false)
    f
  
  let lazy_t_of_json = generic_lazy_t_of
end