Commits

camlspotter  committed 9d63cf6

moved json_wrap from json_wheel

  • Participants
  • Parent commits d0b5325

Comments (0)

Files changed (2)

 FILES[] =
     xcurl
     common
+    json_wrap
     api
     hg
 

File 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