Commits

camlspotter committed c7c1488

hashtbl conversion

Comments (0)

Files changed (9)

 
 Complex types such as open polymorphic variants, open object types and GADTs are not supported.
 
-What to be generated
+What are generated
 ================================
 
 If a type definition of ``t`` (or type definitions concatenated with ``and``) is attached with
         fprintf ppf "@[<v2>Unknown fields of type %s:@ [ @[%a@] ]@]"
           tyname
           (format_list ";@ " (fun ppf -> fprintf ppf "%s")) fields
+    | Unknown_tag (tyname, tag) ->
+        fprintf ppf "@[<v2>Unknown tag of type %s: %s@]"
+          tyname
+          tag
     | Required_field_not_found (tyname, field) ->
         fprintf ppf "Required field not found of type %s: %s"
           tyname
     format_desc desc
     f target
     (format_trace f) trace
+
+module LocalException(A : sig type t end) = struct
+  exception Error of A.t t
+  let exn f v = match f v with
+    | `Ok v -> v
+    | `Error e -> raise (Error e)
+  let catch f v = try `Ok (f v) with Error e -> `Error e
+end
 
 type desc =
   | Exception of exn (** exception of the Decode.tuple, variant or record *)
+
   | Unknown_fields of 
-      string (** type name *) 
+      string        (** type name *) 
       * string list (** unknown fields *)
-      * Obj.t (** value built from the known fields *)
+      * Obj.t       (** value built from the known fields *)
+
   | Unknown_tag of 
-      string (** type name *) 
+      string   (** type name *) 
       * string (** unknown tag *)
+
   | Required_field_not_found of 
-      string (** type name *)
+      string   (** type name *)
       * string (** missing field *)
+
   | Wrong_arity of 
-      int (** expected tuple/variant arity *) 
-      * int (** actual arity *) 
+      int                        (** expected tuple/variant arity *) 
+      * int                      (** actual arity *) 
       * (string * string) option (** type name and tag, if tuple, None *) 
-  | Primitive_decoding_failure of 
-      string (** message *)
+
+  | Primitive_decoding_failure of  string (** message *)
+
   | Sub_decoders_failed_for_one_of of string (** type name *)
 
-type 'target trace = [ `Node of 'target | `Pos of int | `Field of string ] list  
+type 'target trace = [ `Node of 'target | `Pos of int | `Field of string ] list 
+(** Position information of decoded data *) 
 
 type 'target t = desc * 'target * 'target trace
 
 open Format
 
 val format : (formatter -> 'target -> unit) -> formatter -> 'target t -> unit
+(** Print out [t] with its trace *)
 
 val format_desc : formatter -> desc -> unit
+(** Print out [t] without its trace *)
 
 val format_trace_item : 
-  (formatter -> 'a -> unit) 
+  (formatter -> 'target -> unit) 
   -> formatter 
-  -> [< `Field of string | `Node of 'a | `Pos of int ] 
+  -> [< `Field of string | `Node of 'target | `Pos of int ] 
   -> unit
+(** Print out one trace item *)
+
+(** LocalException functor to have exception with target type
+
+  Typical usage: avoid Result monad bind chain, using local an exception.
+    
+  let f decoder = 
+    let module E = LocalException(struct type t = target) in
+    E.catch begin
+       ... 
+       E.exn decoder ...
+       ...
+    end     
+*)
+module LocalException(A : sig type t end) : sig
+  exception Error of A.t t
+  val exn : ('a -> ('b, A.t t) Result.t) -> 'a -> 'b
+  val catch : ('a -> 'b) -> 'a -> ('b, A.t t) Result.t
+end
   else if min <= n && n <= max then `Ok (conv n)
   else `Error "overflow"
 
-let generic_list_of gets (d : (_,_) Decoder.t) ?(trace=[]) v = match gets v with
+let generic_list_of (type target) gets (d : (_,target) Decoder.t) ?(trace=[]) v = match gets v with
   | None -> 
       primitive_decoding_failure 
         "Meta_conv.Internal.generic_list_of: listable expected" 
         v
   | Some xs -> 
       let trace = `Node v::trace in 
-      (* CR jfuruse: We should use exception to speed up *)
-      Result.mapi (fun pos -> d ~trace:(`Pos pos :: trace)) xs
+      let module E = LocalException(struct type t = target end) in
+      E.catch begin fun () -> 
+        list_mapi (fun pos x -> E.exn (d ~trace:(`Pos pos :: trace)) x) xs
+      end () 
 
 let generic_array_of gets d ?trace v =
   fmap Array.of_list (generic_list_of gets d ?trace v)
 
   let format_error ppf (desc,_,_) = Error.format_desc ppf desc
   let format_full_error = Error.format A.format
+
+  (** Hashtbl coders via list *)
+
+  let generic_of_hashtbl of_list of_a of_b tbl =
+    of_list 
+      (fun x -> x)
+      (Hashtbl.fold (fun k v st -> Encode.tuple [of_a k; of_b v]::st) tbl [])
+
+  let generic_hashtbl_of list_of a_of b_of = fun ?trace v ->
+    let ab_of ?(trace=[]) v = 
+      Decode'.tuple ~trace v >>= function
+        | [a; b] -> 
+            a_of ?trace:(Some (`Pos 0 :: `Node v :: trace)) a >>= fun a ->
+            b_of ?trace:(Some (`Pos 0 :: `Node v :: trace)) b >>= fun b ->
+            `Ok (a,b)
+        | xs ->
+            `Error (Error.Wrong_arity (2, List.length xs, None), v, trace)
+    in
+    list_of ab_of ?trace v >>= fun abs ->
+    let tbl = Hashtbl.create 101 in (* CR jfuruse: size fixed *)
+    List.iter (fun (k,v) -> Hashtbl.add tbl k v) abs;
+    `Ok tbl
+
+
+  let format_with encoder ppf t = format ppf (encoder t)
+
 end
   -> ('host lazy_t, 'target) Decoder.t
 (** typical lazy_t_of_<targe_type>. 
     The decoding is done lazily. 
-    Error at the lazy decoding is handled by the error handler, 
+    Error at the deferred decoding is handled by the error handler, 
     normally it should raises <Target_conv>.Error exception.
 *)
 
   -> ('host option, 'target) Decoder.t_exn
 
 val filter_fields : 
-  string list                (** fields known in the type system *) 
-  -> (string * 'target) list (** the actual fields *) 
-  -> (string * 'target) list (** known fields *)
+  string list                  (** fields known in the type system *) 
+  -> (string * 'target) list   (** the actual fields *) 
+  -> (string * 'target) list   (** known fields *)
      * (string * 'target) list (** unknown fields *)
 
 (** helper function for embded record field *)
   -> ('host, 'target) Decoder.t
 
 val variant_unknown_tag_error : 
-  string 
-  -> string 
+  string    (** type name *)
+  -> string (** tag name *) 
   -> ('host, 'target) Decoder.t
 
 val primitive_decoding_failure : 
 
 val bind : ('a, 'error) t -> ('a -> ('b, 'error) t) -> ('b, 'error) t
 val (>>=) : ('a, 'error) t -> ('a -> ('b, 'error) t) -> ('b, 'error) t
+
 val fmap : ('a -> 'b) -> ('a, 'error) t -> ('b, 'error) t
 val (>>|) : ('a, 'error) t -> ('a -> 'b) -> ('b, 'error) t
+
 val map : ('a -> ('b, 'error) t) -> 'a list -> ('b list, 'error) t
 val mapi : (int -> 'a -> ('b, 'error) t) -> 'a list -> ('b list, 'error) t
+
 val fail : 'error -> ('a, 'error) t
 
 val catch : (fail:('error -> 'exn) -> 'a) -> [> ('a, 'error) t ]
   val (>>=) : ('a, 'error) t -> ('a -> ('b, 'error) t) -> ('b, 'error) t
   val (>>|) : ('a, 'error) t -> ('a -> 'b) -> ('b, 'error) t
 end
+
   type 'a decoder     = ('a, target) Decoder.t
   type 'a decoder_exn = ('a, target) Decoder.t_exn
 
+  (* CR jfuruse: Bad name... *)      
   (** Module [Decode'] is a wrapped version of [Decode] *)
   module Decode' : sig
     val tuple        : (target list) decoder
   val from_Ok : [< ('a, target Error.t) Result.t ] -> 'a
   (** If the argument is [`Error e], raises [Error e]. *)
 
+  (** Hashtbl coders via list *)    
+
+  val generic_of_hashtbl : 
+    (target encoder -> target list encoder) (** target_of_list *)
+    -> 'a encoder (** key encoder *)
+    -> 'b encoder (** value encoder *)
+    -> ('a,'b) Hashtbl.t encoder
+
+  val generic_hashtbl_of : 
+    (('a * 'b) decoder -> ('a * 'b) list decoder) (** list_of_target *)
+    -> 'a decoder (** key encoder *)
+    -> 'b decoder (** value encoder *)
+    -> ('a, 'b) Hashtbl.t decoder
+
   open Format
 
   val format_error : formatter -> target Error.t -> unit
+  (** Format the error, without its trace *)
+
   val format_full_error : formatter -> target Error.t -> unit
+  (** Format the error, with its full trace *)
+
+  val format_with : ('host -> target) -> Format.formatter -> 'host -> unit
+  (** Format host data using its encoder *)    
 end
-

ocaml/ocaml_conv.ml

 
 include (val arch)
 
+let ocaml_of_hashtbl x = generic_of_hashtbl ocaml_of_list x
+
+let hashtbl_of_ocaml x = generic_hashtbl_of list_of_ocaml x

ocaml/ocaml_conv.mli

 val ocaml_of_lazy_t    : 'a encoder -> 'a Lazy.t encoder
 val ocaml_of_mc_lazy_t : 'a encoder -> ('a, target) mc_lazy_t encoder
 val ocaml_of_mc_fields : 'a encoder -> (string * 'a) list encoder
+val ocaml_of_hashtbl : 'a encoder -> 'b encoder -> ('a, 'b) Hashtbl.t encoder
 
 val int_of_ocaml       : int decoder
 val nativeint_of_ocaml : nativeint decoder
 val mc_lazy_t_of_ocaml : 'a decoder -> ('a, target) mc_lazy_t decoder
 val mc_fields_of_ocaml : 'a decoder -> (string * 'a) list decoder
 *)
+val hashtbl_of_ocaml : 'a decoder -> 'b decoder -> ('a, 'b) Hashtbl.t decoder