Commits

camlspotter committed dfa1c33

traced_json_conv is no longer required

Comments (0)

Files changed (4)

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
-    
-

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
-

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

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