Commits

camlspotter  committed 6870249

added traced json

  • Participants
  • Parent commits c8fdd6a

Comments (0)

Files changed (9)

File lib/OMakefile

 
 LIBFILES[] =
    json_conv
+   traced_json
+   traced_json_conv
 
 LIB = tiny_json_conv
 

File lib/traced_json.ml

+open Tiny_json
+open Tiny_json.Json
+
+type t = Json.t * Json.t list
+let with_trace j = j, []  
+
+open Format
+
+let format_list = 
+  let rec list (sep : (unit, formatter, unit) format)  f ppf = function
+    | [] -> ()
+    | [x] -> f ppf x
+    | x::xs -> 
+        fprintf ppf "@[%a@]%t%a" 
+  	f x
+  	(fun ppf -> fprintf ppf sep)
+  	(list sep f) xs
+  in
+  list
+
+let format ppf (t, ts) = 
+  Format.fprintf ppf "@[<v>%a@,TRACE: @[<v>%a@]@]" Json_conv.format t
+    (format_list "@," Json_conv.format) ts
+    
+

File lib/traced_json.mli

+open Tiny_json
+open Tiny_json.Json
+
+type t = Json.t * Json.t list
+val with_trace : Json.t -> t
+val format : Format.formatter -> t -> unit
+

File lib/traced_json.mli~

+open Tiny_json
+open Tiny_json.Json
+
+type t = Json.t * Json.t list
+val with_trace : Json.t -> t
+val format : Format.formatter -> t -> unit
+

File lib/traced_json.ml~

+open Tiny_json
+open Tiny_json.Json
+
+type t = Json.t * Json.t list
+
+let format ppf (t, _) = Format.fprintf ppf "%s" (Json.show t)
+

File lib/traced_json_conv.ml

+open Tiny_json
+open Tiny_json.Json
+
+open Meta_conv.Error
+open Meta_conv.Internal
+
+include MakeMinimumCoders(struct
+    
+  type target = Traced_json.t
+
+  let format = Traced_json.format
+
+  module Encode = struct
+    let tuple ts = Array (List.map fst ts), []
+    let variant tag = function
+      | [] -> String tag, []
+      | ts -> Object [tag, Array (List.map fst ts)], []
+    let record tag_ts  = Object (List.map (fun (f,v) -> f, fst v) tag_ts), []
+    let poly_variant = variant
+    let object_ = record
+  end
+  
+  module Decode = struct
+    let tuple = function
+      | (Array ts as v, trace) -> List.map (fun t -> t, (v :: trace)) ts
+      | _ -> failwith "Array expected for tuple"
+  
+    let variant = function 
+      | String tag, _trace -> tag, [] 
+      | (Object [tag, Array ts] as v), trace -> 
+          let trace = v :: trace in
+          tag, List.map (fun t -> t, trace) ts
+      | _ -> failwith "Object expected for variant"
+  
+    let record = function
+      | (Object alist as v), trace -> 
+          let trace = v :: trace in
+          List.map (fun (f,v) -> (f, (v, trace))) alist
+      | _ -> failwith "Object expected for record"
+  
+    let poly_variant = variant
+    let object_ = record
+  end
+end)
+
+let traced_json_of_int n       = Number (float n), []
+let traced_json_of_int32 n     = Number (Int32.to_float n), []
+let traced_json_of_int64 n     = Number (Int64.to_float n), []
+let traced_json_of_nativeint n = Number (Nativeint.to_float n), []
+let traced_json_of_char c      = String (String.make 1 c), []
+let traced_json_of_string s    = String s, []
+let traced_json_of_float n     = Number n, []
+let traced_json_of_list f xs   = Array (List.map (fun x -> fst (f x)) xs), [] 
+let traced_json_of_array f xs  = Array (List.map (fun x -> fst (f x)) (Array.to_list xs)), []
+let traced_json_of_bool b      = Bool b, []
+let traced_json_of_lazy_t f v  = f (Lazy.force v)
+let traced_json_of_option f    = function
+  | None -> Null, []
+  | Some v -> f v
+let traced_json_of_unit ()     = Null, []
+
+open Printf
+
+let errorf v fmt = 
+  kprintf (fun s -> `Error (Primitive_decoding_failure s, v)) fmt
+
+let string_of_traced_json = function
+  | String s, _trace -> `Ok s
+  | v -> errorf v "string_of_traced_json: String expected"
+
+let char_of_traced_json = function
+  | String s, _trace when String.length s = 1 -> `Ok s.[0]
+  | v -> errorf v "char_of_traced_json: a char expected"
+
+let int_check name min max conv v = match v with
+  | Number n, (_trace : Json.t list) -> 
+      begin match integer_of_float min max conv n with
+      | `Ok i -> `Ok i
+      | `Error s -> errorf v "%s_of_traced_json: %s" name s
+      end
+  | _ -> errorf v "%s_of_traced_json: Number expected" name
+
+let int_of_traced_json =
+  int_check "int" (float min_int) (float max_int) int_of_float
+
+let int64_of_traced_json =
+  let open Int64 in
+  int_check "int64" (to_float min_int) (to_float max_int) of_float
+      
+let int32_of_traced_json =
+  let open Int32 in
+  int_check "int32" (to_float min_int) (to_float max_int) of_float
+      
+let nativeint_of_traced_json = 
+  let open Nativeint in
+  int_check "nativeint" (to_float min_int) (to_float max_int) of_float
+      
+let float_of_traced_json = function
+  | Number n, _trace -> `Ok n
+  | n -> errorf n "float_of_traced_json: Number expected"
+
+let bool_of_traced_json = function
+  | Bool b, _trace -> `Ok b
+  | v -> errorf v "bool_of_traced_json: Bool expected"
+
+let unit_of_traced_json = function
+  | Null, _trace -> `Ok ()
+  | v -> errorf v "unit_of_traced_json: Null expected"
+  
+let list_of_traced_json d = generic_list_of (function
+  | (Array xs as v), trace -> Some (List.map (fun x -> x, v::trace) xs)
+  | _ -> None) d
+
+let array_of_traced_json d = generic_array_of (function
+  | (Array xs as v), trace -> Some (List.map (fun x -> x, v::trace) xs)
+  | _ -> None) d
+
+let option_of_traced_json d = generic_option_of (function
+  | Null, _trace -> Some None
+  | v -> Some (Some v)) d
+
+let traced_json_of_mc_option = traced_json_of_option
+let mc_option_of_traced_json = option_of_traced_json
+
+let lazy_t_of_traced_json f = generic_lazy_t_of (fun e -> raise (Error e)) f
+let mc_lazy_t_of_traced_json = generic_mc_lazy_t_of 
+
+let traced_json_of_mc_fields enc xs = Object (List.map (fun (name, a) -> (name, fst (enc a))) xs), []
+
+let mc_fields_of_traced_json dec = generic_mc_fields_of (function 
+  | ((Object js as v), trace) -> 
+      let trace = v :: trace in
+      Some (List.map (fun (k,j) -> k, (j, trace)) js)
+  | _ -> None) dec

File lib/traced_json_conv.mli

+open Tiny_json
+open Meta_conv.Open
+
+include Meta_conv.Internal.MinimumCoders with type target = Traced_json.t
+
+val traced_json_of_int       : int encoder
+val traced_json_of_int32     : int32 encoder
+val traced_json_of_int64     : int64 encoder
+val traced_json_of_nativeint : nativeint encoder
+val traced_json_of_char      : char encoder
+val traced_json_of_string    : string encoder
+val traced_json_of_float     : float encoder
+val traced_json_of_bool      : bool encoder
+val traced_json_of_unit      : unit encoder
+val traced_json_of_list      : ('a encoder) -> 'a list encoder
+val traced_json_of_array     : ('a encoder) -> 'a array encoder
+val traced_json_of_lazy_t    : ('a -> 'b) -> 'a Lazy.t -> 'b
+val traced_json_of_option    : ('a encoder) -> 'a option encoder
+
+val string_of_traced_json    : string decoder
+val char_of_traced_json      : char decoder
+val int_of_traced_json       : int decoder
+val int64_of_traced_json     : int64 decoder
+val int32_of_traced_json     : int32 decoder
+val nativeint_of_traced_json : nativeint decoder
+val float_of_traced_json     : float decoder
+val bool_of_traced_json      : bool decoder
+val unit_of_traced_json      : unit decoder
+val list_of_traced_json      : 'a decoder -> 'a list decoder
+val array_of_traced_json     : 'a decoder -> 'a array decoder
+val option_of_traced_json    : 'a decoder -> 'a option decoder
+val lazy_t_of_traced_json    : 'a decoder -> 'a lazy_t decoder
+val mc_lazy_t_of_traced_json : 'a decoder -> ('a, Traced_json.t) mc_lazy_t decoder
+
+val traced_json_of_mc_option : 'a encoder -> 'a mc_option encoder
+val mc_option_of_traced_json : 'a decoder -> 'a mc_option decoder
+
+val traced_json_of_mc_fields : ('a encoder) -> (string * 'a) list encoder
+val mc_fields_of_traced_json : 'a decoder -> (string * 'a) list decoder

File lib/traced_json_conv.mli~

+open Tiny_json
+open Meta_conv.Open
+
+include Meta_conv.Internal.MinimumCoders with type target = Traced_json.t
+
+val traced_json_of_int       : int -> Traced_Json.t
+val traced_json_of_int32     : int32 -> Traced_Json.t
+val traced_json_of_int64     : int64 -> Traced_Json.t
+val traced_json_of_nativeint : nativeint -> Traced_Json.t
+val traced_json_of_char      : char -> Traced_Json.t
+val traced_json_of_string    : string -> Traced_Json.t
+val traced_json_of_float     : float -> Traced_Json.t
+val traced_json_of_bool      : bool -> Traced_Json.t
+val traced_json_of_unit      : unit -> Traced_Json.t
+val traced_json_of_list      : ('a -> Traced_Json.t) -> 'a list -> Traced_Json.t
+val traced_json_of_array     : ('a -> Traced_Json.t) -> 'a array -> Traced_Json.t
+val traced_json_of_lazy_t    : ('a -> 'b) -> 'a Lazy.t -> 'b
+val traced_json_of_option    : ('a -> Traced_Json.t) -> 'a option -> Traced_Json.t
+
+val string_of_traced_json    : string decoder
+val char_of_traced_json      : char decoder
+val int_of_traced_json       : int decoder
+val int64_of_traced_json     : int64 decoder
+val int32_of_traced_json     : int32 decoder
+val nativeint_of_traced_json : nativeint decoder
+val float_of_traced_json     : float decoder
+val bool_of_traced_json      : bool decoder
+val unit_of_traced_json      : unit decoder
+val list_of_traced_json      : 'a decoder -> 'a list decoder
+val array_of_traced_json     : 'a decoder -> 'a array decoder
+val option_of_traced_json    : 'a decoder -> 'a option decoder
+val lazy_t_of_traced_json    : 'a decoder -> 'a lazy_t decoder
+val mc_lazy_t_of_traced_json : 'a decoder -> ('a, Traced_Json.t) mc_lazy_t decoder
+
+val traced_json_of_mc_option : 'a encoder -> 'a mc_option encoder
+val mc_option_of_traced_json : 'a decoder -> 'a mc_option decoder
+
+val traced_json_of_mc_fields : ('a -> Traced_Json.t) -> (string * 'a) list -> Traced_Json.t
+val mc_fields_of_traced_json : 'a decoder -> (string * 'a) list decoder

File lib/traced_json_conv.ml~

+open Tiny_json
+open Tiny_json.Json
+
+open Meta_conv.Error
+open Meta_conv.Internal
+
+type t = Json.t * Json.t list
+
+include MakeMinimumCoders(struct
+    
+  type target = t
+
+  let format ppf (t, _) = Format.fprintf ppf "%s" (Json.show t)
+
+  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, []
+    let poly_variant = variant
+    let object_ = record
+  end
+  
+  module Decode = struct
+    let tuple (v, trace) = function 
+      | Array ts -> List.map (fun t -> t, (v::trace)) ts
+      | _ -> failwith "Array expected for tuple"
+  
+    let variant = function 
+      | String tag, _trace -> tag, [] 
+      | (Object [tag, Array ts] as v), trace -> 
+          let trace = v :: trace in
+          tag, List.map (fun t -> t, trace) ts
+      | _ -> failwith "Object expected for variant"
+  
+    let record = function
+      | (Object alist as v), trace -> 
+          let trace = v :: trace in
+          List.map (fun (f,v) -> (f, (v, trace))) alist
+      | _ -> failwith "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_option f    = function
+  | None -> Null
+  | Some v -> f v
+let json_of_unit ()     = Null
+
+open Printf
+
+let errorf v fmt = 
+  kprintf (fun s -> `Error (Primitive_decoding_failure s, v)) fmt
+
+let string_of_json = function
+  | String s -> `Ok s
+  | v -> errorf v "string_of_json: String expected"
+
+let char_of_json = function
+  | String s when String.length s = 1 -> `Ok s.[0]
+  | v -> errorf v "char_of_json: a char expected"
+
+let int_check name min max conv v = match v with
+  | Number n -> 
+      begin match integer_of_float min max conv n with
+      | `Ok i -> `Ok i
+      | `Error s -> errorf v "%s_of_json: %s" name s
+      end
+  | _ -> errorf v "%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 = function
+  | Number n -> `Ok n
+  | n -> errorf n "float_of_json: Number expected"
+
+let bool_of_json = function
+  | Bool b -> `Ok b
+  | v -> errorf v "bool_of_json: Bool expected"
+
+let unit_of_json = function
+  | Null -> `Ok ()
+  | v -> errorf v "unit_of_json: Null expected"
+  
+let list_of_json d = generic_list_of (function
+  | Array xs -> Some xs
+  | _ -> None) d
+
+let array_of_json d = generic_array_of (function
+  | Array xs -> Some xs
+  | _ -> None) d
+
+let option_of_json d = generic_option_of (function
+  | Null -> Some None
+  | v -> Some (Some v)) d
+
+let json_of_mc_option = json_of_option
+let mc_option_of_json = option_of_json
+
+let lazy_t_of_json f = generic_lazy_t_of (fun e -> raise (Error e)) f
+let mc_lazy_t_of_json = generic_mc_lazy_t_of 
+
+let json_of_mc_fields enc xs = Object (List.map (fun (name, a) -> (name, enc a)) xs)
+
+let mc_fields_of_json dec = generic_mc_fields_of (function Object js -> Some js | _ -> None) dec