camlspotter avatar camlspotter committed b7abd19

meta_conv 1.0.0

Comments (0)

Files changed (2)

+open Printf
 open Tiny_json
-open Tiny_json.Json
-
-open Meta_conv.Error
+open Json
+open Meta_conv.Open
 open Meta_conv.Internal
 
-include MakeMinimumCoders(struct
+(* encoders ***************************************************************)
+
+include Meta_conv.Internal.Make(struct 
     
   type target = Json.t
 
-  let format ppf t = Format.fprintf ppf "%s" (Json.show t)
+  let rec format_list sep f ppf = function
+    | [] -> ()
+    | [x] -> f ppf x
+    | x::xs -> f ppf x; Format.fprintf ppf sep; format_list sep f ppf xs
+
+  let rec format ppf = 
+    let open Format in
+    function
+      | String s -> fprintf ppf "%S" s
+      | Number f -> fprintf ppf "%f" f
+      | Object o -> 
+          fprintf ppf "{ @[%a@] }"
+            (format_list ";@ " (fun ppf (s,v) -> fprintf ppf "@[%s= @[<v2>%a@]@]" s format v)) o
+      | Array ts -> 
+          fprintf ppf "[ @[%a@] ]"
+            (format_list ";@ " (fun ppf v -> fprintf ppf "@[<v2>%a@]@]" format v)) ts
+      | Bool b -> fprintf ppf "%b" b
+      | Null -> fprintf ppf "()"
 
   module Encode = struct
     let tuple ts       = Array ts
 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
-let json_of_unit ()     = Null
 
-open Printf
+(* decoders ***************************************************************)
 
-let errorf v fmt = 
-  kprintf (fun s -> `Error (Primitive_decoding_failure s, v)) fmt
+let failwithf fmt = kprintf (fun s -> raise (Failure s)) fmt
 
-let string_of_json = function
-  | String s -> `Ok s
-  | v -> errorf v "string_of_json: String expected"
+let string_of_json = prim_decode (function
+  | String s -> s
+  | _ -> failwith "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 char_of_json = prim_decode (function
+  | String s when String.length s = 1 -> s.[0]
+  | _ -> failwith "char_of_json: a char expected")
 
-let int_check name min max conv v = match v with
+let int_check name min max conv = prim_decode (function 
   | 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
+      | `Ok v -> v
+      | `Error s -> failwithf "%s_of_json: %s" name s
       end
-  | _ -> errorf v "%s_of_json: Number expected" name
+  | _ -> failwithf "%s_of_json: Number expected" name)
 
 let int_of_json =
   int_check "int" (float min_int) (float max_int) int_of_float
   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 float_of_json = prim_decode (function
+  | Number n -> n
+  | _ -> failwith "float_of_json: Number expected")
 
-let bool_of_json = function
-  | Bool b -> `Ok b
-  | v -> errorf v "bool_of_json: Bool expected"
+let bool_of_json = prim_decode (function
+  | Bool b -> b
+  | _ -> failwith "bool_of_json: Bool expected")
 
-let unit_of_json = function
-  | Null -> `Ok ()
-  | v -> errorf v "unit_of_json: Null expected"
+let unit_of_json = prim_decode (function
+  | Null -> ()
+  | _ -> failwith "unit_of_json: Null expected")
   
-let list_of_json d = generic_list_of (function
-  | Array xs -> Some xs
-  | _ -> None) d
+let list_of_json f = 
+  generic_list_of (function Array xs -> Some xs | _ -> None) f
 
-let array_of_json d = generic_array_of (function
-  | Array xs -> Some xs
-  | _ -> None) d
+let array_of_json f = 
+  generic_array_of (function Array xs -> Some xs | _ -> None) f
 
-let option_of_json d = generic_option_of (function
-  | Null -> Some None
-  | v -> Some (Some v)) d
+let option_of_json f = generic_option_of 
+  (function Null -> Some None | v -> Some (Some v))
+  f
 
-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 lazy_t_of_json d = generic_lazy_t_of (fun e -> raise (Error e)) d
+let mc_lazy_t_of_json (d : 'a decoder) = (generic_mc_lazy_t_of d : ('a, Json.t) mc_lazy_t decoder)
 
 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

lib/json_conv.mli

 open Tiny_json
+open Meta_conv.Types
 open Meta_conv.Open
 
-include Meta_conv.Internal.MinimumCoders with type target = Json.t
+include Meta_conv.Types.S with type target = Json.t
 
-val json_of_int       : int -> Json.t
-val json_of_int32     : int32 -> Json.t
-val json_of_int64     : int64 -> Json.t
-val json_of_nativeint : nativeint -> Json.t
-val json_of_char      : char -> Json.t
-val json_of_string    : string -> Json.t
-val json_of_float     : float -> Json.t
-val json_of_bool      : bool -> Json.t
-val json_of_unit      : unit -> Json.t
-val json_of_list      : ('a -> Json.t) -> 'a list -> Json.t
-val json_of_array     : ('a -> Json.t) -> 'a array -> Json.t
-val json_of_lazy_t    : ('a -> 'b) -> 'a Lazy.t -> 'b
-val json_of_option    : ('a -> Json.t) -> 'a option -> Json.t
+val json_of_int       : int encoder
+val json_of_nativeint : nativeint encoder
+val json_of_unit      : unit encoder
+val json_of_bool      : bool encoder
+val json_of_int32     : int32 encoder
+val json_of_int64     : int64 encoder
+val json_of_float     : float encoder
+val json_of_char      : char encoder
+val json_of_string    : string encoder
+val json_of_list      : 'a encoder -> 'a list encoder
+val json_of_array     : 'a encoder -> 'a array encoder
+val json_of_option    : 'a encoder -> 'a option encoder
+val json_of_lazy_t    : 'a encoder -> 'a Lazy.t encoder
+(* val json_of_mc_lazy_t : 'a encoder -> ('a, target) mc_lazy_t encoder *)
+val json_of_mc_fields : 'a encoder -> (string * 'a) list encoder
 
+val int_of_json       : int decoder
+val nativeint_of_json : nativeint decoder
+val unit_of_json      : unit decoder
+val bool_of_json      : bool decoder
+val int32_of_json     : int32 decoder
+val int64_of_json     : int64 decoder
+val float_of_json     : float decoder
+val char_of_json      : char decoder
 val string_of_json    : string decoder
-val char_of_json      : char decoder
-val int_of_json       : int decoder
-val int64_of_json     : int64 decoder
-val int32_of_json     : int32 decoder
-val nativeint_of_json : nativeint decoder
-val float_of_json     : float decoder
-val bool_of_json      : bool decoder
-val unit_of_json      : unit decoder
 val list_of_json      : 'a decoder -> 'a list decoder
 val array_of_json     : 'a decoder -> 'a array decoder
 val option_of_json    : 'a decoder -> 'a option decoder
 val lazy_t_of_json    : 'a decoder -> 'a lazy_t decoder
-val mc_lazy_t_of_json : 'a decoder -> ('a, Json.t) mc_lazy_t decoder
-
-val json_of_mc_option : 'a encoder -> 'a mc_option encoder
-val mc_option_of_json : 'a decoder -> 'a mc_option decoder
-
-val json_of_mc_fields : ('a -> Json.t) -> (string * 'a) list -> Json.t
+val mc_lazy_t_of_json : 'a decoder -> ('a, target) mc_lazy_t decoder
 val mc_fields_of_json : 'a decoder -> (string * 'a) list decoder
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.