1. camlspotter
  2. json-wheel-custom

Source

json-wheel-custom / 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

open Json

module Json_conv = struct
  module Encode = struct
    let int n       = Float (float n)
    let int32 n     = Float (Int32.to_float n)
    let int64 n     = Float (Int64.to_float n)
    let nativeint n = Float (Nativeint.to_float n)
    let char c      = String (String.make 1 c)
    let string s    = String s
    let float n     = Float (float n)
    let list f xs   = Array (List.map f xs)
    let array f xs  = Array (List.map f (Array.to_list xs))
    let bool b      = Bool b
    let lazy_t f v  = f (Lazy.force v)
    let option f    = function
      | None -> Null
      | Some v -> f v
  
    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       = Encode.int
  let json_of_int32     = Encode.int32
  let json_of_int64     = Encode.int64
  let json_of_nativeint = Encode.nativeint
  let json_of_char      = Encode.char
  let json_of_string    = Encode.string
  let json_of_float     = Encode.float
  let json_of_list      = Encode.list
  let json_of_array     = Encode.array
  let json_of_bool      = Encode.bool
  let json_of_lazy_t    = Encode.lazy_t
  let json_of_option    = Encode.option
  
  module Decode = struct
    exception Error of string
  
    let errorf fmt = Printf.ksprintf (fun s -> raise (Error s)) fmt
  
    let string = function
      | String s -> s
      | _ -> errorf "String expected"
  
    let char = function
      | String s when String.length s = 1 -> s.[0]
      | _ -> errorf "Char expected"
  
    let int_check name min max conv v =
      if floor v <> v then errorf "overflow: %f is not an integer" v
      else if min <= v && v <= max then conv v
      else errorf "overflow: %f is outside of legal range of type %s" v name
  
    let int n = match n with
      | Float n -> int_check "int" (float min_int) (float max_int) int_of_float n
      | _ -> errorf "Int expected"
          
    let int64 n = 
      let open Int64 in
      match n with
      | Float n ->
          int_check "int64" (to_float min_int) (to_float max_int) of_float n
      | _ -> errorf "Int64 expected"
          
    let int32 n = 
      let open Int32 in
      match n with
      | Float n ->
          int_check "int32" (to_float min_int) (to_float max_int) of_float n
      | _ -> errorf "Int32 expected"
          
    let nativeint n = 
      let open Nativeint in
      match n with
      | Float n ->
          int_check "nativeint" (to_float min_int) (to_float max_int) of_float n
      | _ -> errorf "Nativeint expected"
          
    let float = function
      | Float n -> n
      | _ -> errorf "Float expected"
  
    let list d = function
      | Array xs -> List.map d xs
      | _ -> errorf "Array expected for list"
  
    let array d = function
      | Array xs -> Array.of_list (List.map d xs)
      | _ -> errorf "Array expected for array"
  
    let bool = function
      | Bool b -> b
      | _ -> errorf "Bool expected"
  
    let option f = function
      | Null -> None
      | v -> Some (f v)
  
    let lazy_t f v = Lazy.from_val (f v)
  
    let tuple arity = function 
      | Array ts when List.length ts = arity -> ts
      | Array _ -> errorf "Tuple arity mismatch"
      | _ -> errorf "Array expected for array"
  
    let variant = function 
      | String tag -> tag, [] 
      | Object [tag, Array ts] when ts <> [] -> tag, ts
      | Object [tag, Array []] -> errorf "Variant has Object [_, Array []]"
      | Object _ -> errorf "Variant arity mismatch"
      | _ -> errorf "Object expected for variant"
  
    let record = function
      | Object alist -> alist
      | _ -> errorf "Object expected for record"
  
  end
  
  let int_of_json       = Decode.int
  let int32_of_json     = Decode.int32
  let int64_of_json     = Decode.int64
  let nativeint_of_json = Decode.nativeint
  let char_of_json      = Decode.char
  let string_of_json    = Decode.string
  let float_of_json     = Decode.float
  let list_of_json      = Decode.list
  let array_of_json     = Decode.array
  let bool_of_json      = Decode.bool
  let lazy_of_json_t    = Decode.lazy_t
  let option_of_json    = Decode.option
end