Data_encoding: split implementation

In an effort to keep a clean commit history, the interface is unchanged.

src/lib_data_encoding/binary.mli

@@ -0,0 +1,52 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2018.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+val length : 'a Encoding.t -> 'a -> int
+val read : 'a Encoding.t -> MBytes.t -> int -> int -> (int * 'a) option
+val write : 'a Encoding.t -> 'a -> MBytes.t -> int -> int option
+val to_bytes : 'a Encoding.t -> 'a -> MBytes.t
+val of_bytes : 'a Encoding.t -> MBytes.t -> 'a option
+val of_bytes_exn : 'a Encoding.t -> MBytes.t -> 'a
+
+(** [to_bytes_list ?copy_blocks blocks_size encod data] encode the
+    given data as a list of successive blocks of length
+    'blocks_size' at most.
+
+    NB. If 'copy_blocks' is false (default), the blocks of the list
+    can be garbage-collected only when all the blocks are
+    unreachable (because of the 'optimized' implementation of
+    MBytes.sub used internally *)
+val to_bytes_list : ?copy_blocks:bool -> int  -> 'a Encoding.t -> 'a -> MBytes.t list
+
+(** This type is used when decoding binary data incrementally.
+    - In case of 'Success', the decoded data, the size of used data
+     to decode the result, and the remaining data are returned
+    - In case of error, 'Error' is returned
+    - 'Await' status embeds a function that waits for additional data
+     to continue decoding, when given data are not sufficient *)
+type 'a status =
+  | Success of { res : 'a ; res_len : int ; remaining : MBytes.t list }
+  | Await of (MBytes.t -> 'a status)
+  | Error
+
+(** This function allows to decode (or to initialize decoding) a
+    stream of 'MByte.t'. The given data encoding should have a
+    'Fixed' or a 'Dynamic' size, otherwise an exception
+    'Invalid_argument "streaming data with variable size"' is
+    raised *)
+val read_stream_of_bytes : ?init:MBytes.t list -> 'a Encoding.t -> 'a status
+
+(** Like read_stream_of_bytes, but only checks that the stream can
+    be read. Note that this is an approximation because failures
+    that may come from conversion functions present in encodings are
+    not checked *)
+val check_stream_of_bytes : ?init:MBytes.t list -> 'a Encoding.t -> unit status
+
+val fixed_length : 'a Encoding.t -> int option
+val fixed_length_exn : 'a Encoding.t -> int

src/lib_data_encoding/bson.ml

@@ -0,0 +1,14 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2018.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+type bson = Json_repr_bson.bson
+type t = bson
+
+let construct e v = Json_repr_bson.Json_encoding.construct (Json.convert e) v
+let destruct e v = Json_repr_bson.Json_encoding.destruct (Json.convert e) v

src/lib_data_encoding/bson.mli

@@ -0,0 +1,18 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2018.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+type bson = Json_repr_bson.bson
+type t = bson
+
+(** Construct a BSON object from an encoding. *)
+val construct : 't Encoding.t -> 't -> bson
+
+(** Destruct a BSON object into a value.
+    Fail with an exception if the JSON object and encoding do not match.. *)
+val destruct : 't Encoding.t -> bson -> 't

src/lib_data_encoding/encoding.ml

@@ -0,0 +1,567 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2018.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+exception No_case_matched
+exception Unexpected_tag of int
+exception Duplicated_tag of int
+exception Invalid_tag of int * [ `Uint8 | `Uint16 ]
+exception Unexpected_enum of string * string list
+exception Invalid_size of int
+exception Int_out_of_range of int * int * int
+exception Float_out_of_range of float * float * float
+exception Parse_error of string
+
+(*TODO: provide a more specialised function that doesn't need as many closures*)
+let apply ?(error=No_case_matched) fs v =
+  let rec loop = function
+    | [] -> raise error
+    | f :: fs ->
+        match f v with
+        | Some l -> l
+        | None -> loop fs in
+  loop fs
+
+
+module Size = struct
+  let bool = 1
+  let int8 = 1
+  let uint8 = 1
+  let char = 1
+  let int16 = 2
+  let uint16 = 2
+  let uint30 = 4
+  let uint32 = 4
+  let uint64 = 8
+  let int31 = 4
+  let int32 = 4
+  let int64 = 8
+  let float = 8
+end
+
+type tag_size = [ `Uint8 | `Uint16 ]
+
+let tag_size = function
+  | `Uint8 -> Size.uint8
+  | `Uint16 -> Size.uint16
+
+module Kind = struct
+
+  type t =
+    [ `Fixed of int
+    | `Dynamic
+    | `Variable ]
+
+  type length =
+    [ `Fixed of int
+    | `Variable ]
+
+  type enum =
+    [ `Dynamic
+    | `Variable ]
+
+  let combine name : t -> t -> t = fun k1 k2 ->
+    match k1, k2 with
+    | `Fixed n1, `Fixed n2 -> `Fixed (n1 + n2)
+    | `Dynamic, `Dynamic | `Fixed _, `Dynamic
+    | `Dynamic, `Fixed _ -> `Dynamic
+    | `Variable, `Fixed _
+    | (`Dynamic | `Fixed _), `Variable -> `Variable
+    | `Variable, `Dynamic ->
+        Printf.ksprintf invalid_arg
+          "Cannot merge two %s when the left element is of variable length \
+           and the right one of dynamic length. \
+           You should use the reverse order, or wrap the second one \
+           with Data_encoding.dynamic_size."
+          name
+    | `Variable, `Variable ->
+        Printf.ksprintf invalid_arg
+          "Cannot merge two %s with variable length. \
+           You should wrap one of them with Data_encoding.dynamic_size."
+          name
+
+  let merge : t -> t -> t = fun k1 k2 ->
+    match k1, k2 with
+    | `Fixed n1, `Fixed n2 when n1 = n2 -> `Fixed n1
+    | `Fixed _, `Fixed _ -> `Dynamic
+    | `Dynamic, `Dynamic | `Fixed _, `Dynamic
+    | `Dynamic, `Fixed _ -> `Dynamic
+    | `Variable, (`Dynamic | `Fixed _)
+    | (`Dynamic | `Fixed _), `Variable
+    | `Variable, `Variable -> `Variable
+
+  let merge_list sz : t list -> t = function
+    | [] -> assert false (* should be rejected by Data_encoding.union *)
+    | k :: ks ->
+        match List.fold_left merge k ks with
+        | `Fixed n -> `Fixed (n + tag_size sz)
+        | k -> k
+
+end
+
+type case_tag = Tag of int | Json_only
+
+type 'a desc =
+  | Null : unit desc
+  | Empty : unit desc
+  | Ignore : unit desc
+  | Constant : string -> unit desc
+  | Bool : bool desc
+  | Int8 : int desc
+  | Uint8 : int desc
+  | Int16 : int desc
+  | Uint16 : int desc
+  | Int31 : int desc
+  | Int32 : Int32.t desc
+  | Int64 : Int64.t desc
+  | RangedInt : { minimum : int ; maximum : int } -> int desc
+  | RangedFloat : { minimum : float ; maximum : float } -> float desc
+  | Float : float desc
+  | Bytes : Kind.length -> MBytes.t desc
+  | String : Kind.length -> string desc
+  | String_enum : ('a, string * int) Hashtbl.t * 'a array -> 'a desc
+  | Array : 'a t -> 'a array desc
+  | List : 'a t -> 'a list desc
+  | Obj : 'a field -> 'a desc
+  | Objs : Kind.t * 'a t * 'b t -> ('a * 'b) desc
+  | Tup : 'a t -> 'a desc
+  | Tups : Kind.t * 'a t * 'b t -> ('a * 'b) desc
+  | Union : Kind.t * tag_size * 'a case list -> 'a desc
+  | Mu : Kind.enum * string * ('a t -> 'a t) -> 'a desc
+  | Conv :
+      { proj : ('a -> 'b) ;
+        inj : ('b -> 'a) ;
+        encoding : 'b t ;
+        schema : Json_schema.schema option } -> 'a desc
+  | Describe :
+      { title : string option ;
+        description : string option ;
+        encoding : 'a t } -> 'a desc
+  | Def : { name : string ;
+            encoding : 'a t } -> 'a desc
+  | Splitted :
+      { encoding : 'a t ;
+        json_encoding : 'a Json_encoding.encoding ;
+        is_obj : bool ; is_tup : bool } -> 'a desc
+  | Dynamic_size : 'a t -> 'a desc
+  | Delayed : (unit -> 'a t) -> 'a desc
+
+and _ field =
+  | Req : string * 'a t -> 'a field
+  | Opt : Kind.enum * string * 'a t -> 'a option field
+  | Dft : string * 'a t * 'a -> 'a field
+
+and 'a case =
+  | Case : { name : string option ;
+             encoding : 'a t ;
+             proj : ('t -> 'a option) ;
+             inj : ('a -> 't) ;
+             tag : case_tag } -> 't case
+
+and 'a t = {
+  encoding: 'a desc ;
+  mutable json_encoding: 'a Json_encoding.encoding option ;
+}
+
+type signed_integer = [ `Int31 | `Int16 | `Int8 ]
+type unsigned_integer = [ `Uint30 | `Uint16 | `Uint8 ]
+type integer = [ signed_integer | unsigned_integer ]
+
+let signed_range_to_size min max : [> signed_integer ] =
+  if min >= ~-128 && max <= 127
+  then `Int8
+  else if min >= ~-32_768 && max <= 32_767
+  then `Int16
+  else `Int31
+
+(* max should be centered at zero *)
+let unsigned_range_to_size max : [> unsigned_integer ] =
+  if max <= 255
+  then `Uint8
+  else if max <= 65535
+  then `Uint16
+  else `Uint30
+
+let integer_to_size = function
+  | `Int31 -> Size.int31
+  | `Int16 -> Size.int16
+  | `Int8 -> Size.int8
+  | `Uint30 -> Size.uint30
+  | `Uint16 -> Size.uint16
+  | `Uint8 -> Size.uint8
+
+let range_to_size ~minimum ~maximum : integer =
+  if minimum < 0
+  then signed_range_to_size minimum maximum
+  else unsigned_range_to_size (maximum - minimum)
+
+let enum_size arr =
+  unsigned_range_to_size (Array.length arr)
+
+type 'a encoding = 'a t
+
+let rec classify : type a. a t -> Kind.t = fun e ->
+  match e.encoding with
+  (* Fixed *)
+  | Null -> `Fixed 0
+  | Empty -> `Fixed 0
+  | Constant _ -> `Fixed 0
+  | Bool -> `Fixed Size.bool
+  | Int8 -> `Fixed Size.int8
+  | Uint8 -> `Fixed Size.uint8
+  | Int16 -> `Fixed Size.int16
+  | Uint16 -> `Fixed Size.uint16
+  | Int31 -> `Fixed Size.int31
+  | Int32 -> `Fixed Size.int32
+  | Int64 -> `Fixed Size.int64
+  | RangedInt { minimum ; maximum } ->
+      `Fixed (integer_to_size @@ range_to_size ~minimum ~maximum)
+  | Float -> `Fixed Size.float
+  | RangedFloat _ -> `Fixed Size.float
+  (* Tagged *)
+  | Bytes kind -> (kind :> Kind.t)
+  | String kind -> (kind :> Kind.t)
+  | String_enum (_, cases) ->
+      `Fixed (integer_to_size (enum_size cases))
+  | Obj (Opt (kind, _, _)) -> (kind :> Kind.t)
+  | Objs (kind, _, _) -> kind
+  | Tups (kind, _, _) -> kind
+  | Union (kind, _, _) -> (kind :> Kind.t)
+  | Mu (kind, _, _) -> (kind :> Kind.t)
+  (* Variable *)
+  | Ignore -> `Variable
+  | Array _ -> `Variable
+  | List _ -> `Variable
+  (* Recursive *)
+  | Obj (Req (_, encoding)) -> classify encoding
+  | Obj (Dft (_, encoding, _)) -> classify encoding
+  | Tup encoding -> classify encoding
+  | Conv { encoding } -> classify encoding
+  | Describe { encoding } -> classify encoding
+  | Def { encoding } -> classify encoding
+  | Splitted { encoding } -> classify encoding
+  | Dynamic_size _ -> `Dynamic
+  | Delayed f -> classify (f ())
+
+let make ?json_encoding encoding = { encoding ; json_encoding }
+
+module Fixed = struct
+  let string n = make @@ String (`Fixed n)
+  let bytes n = make @@ Bytes (`Fixed n)
+end
+
+module Variable = struct
+  let string = make @@ String `Variable
+  let bytes = make @@ Bytes `Variable
+  let check_not_variable name e =
+    match classify e with
+    | `Variable ->
+        Printf.ksprintf invalid_arg
+          "Cannot insert variable length element in %s. \
+           You should wrap the contents using Data_encoding.dynamic_size." name
+    | `Dynamic | `Fixed _ -> ()
+  let array e =
+    check_not_variable "an array" e ;
+    make @@ Array e
+  let list e =
+    check_not_variable "a list" e ;
+    make @@ List e
+end
+
+let dynamic_size e =
+  make @@ Dynamic_size e
+
+let delayed f =
+  make @@ Delayed f
+
+let null = make @@ Null
+let empty = make @@ Empty
+let unit = make @@ Ignore
+let constant s = make @@ Constant s
+let bool = make @@ Bool
+let int8 = make @@ Int8
+let uint8 = make @@ Uint8
+let int16 = make @@ Int16
+let uint16 = make @@ Uint16
+let int31 = make @@ Int31
+let int32 = make @@ Int32
+let ranged_int minimum maximum =
+  let minimum = min minimum maximum
+  and maximum = max minimum maximum in
+  if minimum < -(1 lsl 30) || (1 lsl 30) - 1 < maximum then
+    invalid_arg "Data_encoding.ranged_int" ;
+  make @@ RangedInt { minimum ; maximum  }
+let ranged_float minimum maximum =
+  let minimum = min minimum maximum
+  and maximum = max minimum maximum in
+  make @@ RangedFloat { minimum ; maximum }
+let int64 = make @@ Int64
+let float = make @@ Float
+
+let string = dynamic_size Variable.string
+let bytes = dynamic_size Variable.bytes
+let array e = dynamic_size (Variable.array e)
+let list e = dynamic_size (Variable.list e)
+
+let string_enum = function
+  | [] -> invalid_arg "data_encoding.string_enum: cannot have zero cases"
+  | [ _case ] -> invalid_arg "data_encoding.string_enum: cannot have a single case, use constant instead"
+  | _ :: _ as cases ->
+      let arr = Array.of_list (List.map snd cases) in
+      let tbl = Hashtbl.create (Array.length arr) in
+      List.iteri (fun ind (str, a) -> Hashtbl.add tbl a (str, ind)) cases ;
+      make @@ String_enum (tbl, arr)
+
+let conv proj inj ?schema encoding =
+  make @@ Conv { proj ; inj ; encoding ; schema }
+
+let describe ?title ?description encoding =
+  match title, description with
+  | None, None -> encoding
+  | _, _ -> make @@ Describe { title ; description ; encoding }
+
+let def name encoding = make @@ Def { name ; encoding }
+
+let req ?title ?description n t =
+  Req (n, describe ?title ?description t)
+let opt ?title ?description n encoding =
+  let kind =
+    match classify encoding with
+    | `Variable -> `Variable
+    | `Fixed _ | `Dynamic -> `Dynamic in
+  Opt (kind, n, make @@ Describe { title ; description ; encoding })
+let varopt ?title ?description n encoding =
+  Opt (`Variable, n, make @@ Describe { title ; description ; encoding })
+let dft ?title ?description n t d =
+  Dft (n, describe ?title ?description t, d)
+
+let raw_splitted ~json ~binary =
+  make @@ Splitted { encoding = binary ;
+                     json_encoding = json ;
+                     is_obj = false ;
+                     is_tup = false }
+
+let rec is_obj : type a. a t -> bool = fun e ->
+  match e.encoding with
+  | Obj _ -> true
+  | Objs _ (* by construction *) -> true
+  | Conv { encoding = e } -> is_obj e
+  | Dynamic_size e  -> is_obj e
+  | Union (_,_,cases) ->
+      List.for_all (fun (Case { encoding = e }) -> is_obj e) cases
+  | Empty -> true
+  | Ignore -> true
+  | Mu (_,_,self) -> is_obj (self e)
+  | Splitted { is_obj } -> is_obj
+  | Delayed f -> is_obj (f ())
+  | Describe { encoding } -> is_obj encoding
+  | Def { encoding } -> is_obj encoding
+  | _ -> false
+
+let rec is_tup : type a. a t -> bool = fun e ->
+  match e.encoding with
+  | Tup _ -> true
+  | Tups _ (* by construction *) -> true
+  | Conv { encoding = e } -> is_tup e
+  | Dynamic_size e  -> is_tup e
+  | Union (_,_,cases) ->
+      List.for_all (function Case { encoding = e} -> is_tup e) cases
+  | Mu (_,_,self) -> is_tup (self e)
+  | Splitted { is_tup } -> is_tup
+  | Delayed f -> is_tup (f ())
+  | Describe { encoding } -> is_tup encoding
+  | Def { encoding } -> is_tup encoding
+  | _ -> false
+
+let raw_merge_objs e1 e2 =
+  let kind = Kind.combine "objects" (classify e1) (classify e2) in
+  make @@ Objs (kind, e1, e2)
+
+let obj1 f1 = make @@ Obj f1
+let obj2 f2 f1 =
+  raw_merge_objs (obj1 f2) (obj1 f1)
+let obj3 f3 f2 f1 =
+  raw_merge_objs (obj1 f3) (obj2 f2 f1)
+let obj4 f4 f3 f2 f1 =
+  raw_merge_objs (obj2 f4 f3) (obj2 f2 f1)
+let obj5 f5 f4 f3 f2 f1 =
+  raw_merge_objs (obj1 f5) (obj4 f4 f3 f2 f1)
+let obj6 f6 f5 f4 f3 f2 f1 =
+  raw_merge_objs (obj2 f6 f5) (obj4 f4 f3 f2 f1)
+let obj7 f7 f6 f5 f4 f3 f2 f1 =
+  raw_merge_objs (obj3 f7 f6 f5) (obj4 f4 f3 f2 f1)
+let obj8 f8 f7 f6 f5 f4 f3 f2 f1 =
+  raw_merge_objs (obj4 f8 f7 f6 f5) (obj4 f4 f3 f2 f1)
+let obj9 f9 f8 f7 f6 f5 f4 f3 f2 f1 =
+  raw_merge_objs (obj1 f9) (obj8 f8 f7 f6 f5 f4 f3 f2 f1)
+let obj10 f10 f9 f8 f7 f6 f5 f4 f3 f2 f1 =
+  raw_merge_objs (obj2 f10 f9) (obj8 f8 f7 f6 f5 f4 f3 f2 f1)
+
+let merge_objs o1 o2 =
+  if is_obj o1 && is_obj o2 then
+    raw_merge_objs o1 o2
+  else
+    invalid_arg "Json_encoding.merge_objs"
+
+let raw_merge_tups e1 e2 =
+  let kind = Kind.combine "tuples" (classify e1) (classify e2) in
+  make @@ Tups (kind, e1, e2)
+
+let tup1 e1 = make @@ Tup e1
+let tup2 e2 e1 =
+  raw_merge_tups (tup1 e2) (tup1 e1)
+let tup3 e3 e2 e1 =
+  raw_merge_tups (tup1 e3) (tup2 e2 e1)
+let tup4 e4 e3 e2 e1 =
+  raw_merge_tups (tup2 e4 e3) (tup2 e2 e1)
+let tup5 e5 e4 e3 e2 e1 =
+  raw_merge_tups (tup1 e5) (tup4 e4 e3 e2 e1)
+let tup6 e6 e5 e4 e3 e2 e1 =
+  raw_merge_tups (tup2 e6 e5) (tup4 e4 e3 e2 e1)
+let tup7 e7 e6 e5 e4 e3 e2 e1 =
+  raw_merge_tups (tup3 e7 e6 e5) (tup4 e4 e3 e2 e1)
+let tup8 e8 e7 e6 e5 e4 e3 e2 e1 =
+  raw_merge_tups (tup4 e8 e7 e6 e5) (tup4 e4 e3 e2 e1)
+let tup9 e9 e8 e7 e6 e5 e4 e3 e2 e1 =
+  raw_merge_tups (tup1 e9) (tup8 e8 e7 e6 e5 e4 e3 e2 e1)
+let tup10 e10 e9 e8 e7 e6 e5 e4 e3 e2 e1 =
+  raw_merge_tups (tup2 e10 e9) (tup8 e8 e7 e6 e5 e4 e3 e2 e1)
+
+let merge_tups t1 t2 =
+  if is_tup t1 && is_tup t2 then
+    raw_merge_tups t1 t2
+  else
+    invalid_arg "Tezos_serial.Encoding.merge_tups"
+
+let conv3 ty =
+  conv
+    (fun (c, b, a) -> (c, (b, a)))
+    (fun (c, (b, a)) -> (c, b, a))
+    ty
+let obj3 f3 f2 f1 = conv3 (obj3 f3 f2 f1)
+let tup3 f3 f2 f1 = conv3 (tup3 f3 f2 f1)
+let conv4 ty =
+  conv
+    (fun (d, c, b, a) -> ((d, c), (b, a)))
+    (fun ((d, c), (b, a)) -> (d, c, b, a))
+    ty
+let obj4 f4 f3 f2 f1 = conv4 (obj4 f4 f3 f2 f1)
+let tup4 f4 f3 f2 f1 = conv4 (tup4 f4 f3 f2 f1)
+let conv5 ty =
+  conv
+    (fun (e, d, c, b, a) -> (e, ((d, c), (b, a))))
+    (fun (e, ((d, c), (b, a))) -> (e, d, c, b, a))
+    ty
+let obj5 f5 f4 f3 f2 f1 = conv5 (obj5 f5 f4 f3 f2 f1)
+let tup5 f5 f4 f3 f2 f1 = conv5 (tup5 f5 f4 f3 f2 f1)
+let conv6 ty =
+  conv
+    (fun (f, e, d, c, b, a) -> ((f, e), ((d, c), (b, a))))
+    (fun ((f, e), ((d, c), (b, a))) -> (f, e, d, c, b, a))
+    ty
+let obj6 f6 f5 f4 f3 f2 f1 = conv6 (obj6 f6 f5 f4 f3 f2 f1)
+let tup6 f6 f5 f4 f3 f2 f1 = conv6 (tup6 f6 f5 f4 f3 f2 f1)
+let conv7 ty =
+  conv
+    (fun (g, f, e, d, c, b, a) -> ((g, (f, e)), ((d, c), (b, a))))
+    (fun ((g, (f, e)), ((d, c), (b, a))) -> (g, f, e, d, c, b, a))
+    ty
+let obj7 f7 f6 f5 f4 f3 f2 f1 = conv7 (obj7 f7 f6 f5 f4 f3 f2 f1)
+let tup7 f7 f6 f5 f4 f3 f2 f1 = conv7 (tup7 f7 f6 f5 f4 f3 f2 f1)
+let conv8 ty =
+  conv (fun (h, g, f, e, d, c, b, a) ->
+      (((h, g), (f, e)), ((d, c), (b, a))))
+    (fun (((h, g), (f, e)), ((d, c), (b, a))) ->
+       (h, g, f, e, d, c, b, a))
+    ty
+let obj8 f8 f7 f6 f5 f4 f3 f2 f1 = conv8 (obj8 f8 f7 f6 f5 f4 f3 f2 f1)
+let tup8 f8 f7 f6 f5 f4 f3 f2 f1 = conv8 (tup8 f8 f7 f6 f5 f4 f3 f2 f1)
+let conv9 ty =
+  conv
+    (fun (i, h, g, f, e, d, c, b, a) ->
+       (i, (((h, g), (f, e)), ((d, c), (b, a)))))
+    (fun (i, (((h, g), (f, e)), ((d, c), (b, a)))) ->
+       (i, h, g, f, e, d, c, b, a))
+    ty
+let obj9 f9 f8 f7 f6 f5 f4 f3 f2 f1 =
+  conv9 (obj9 f9 f8 f7 f6 f5 f4 f3 f2 f1)
+let tup9 f9 f8 f7 f6 f5 f4 f3 f2 f1 =
+  conv9 (tup9 f9 f8 f7 f6 f5 f4 f3 f2 f1)
+let conv10 ty =
+  conv
+    (fun (j, i, h, g, f, e, d, c, b, a) ->
+       ((j, i), (((h, g), (f, e)), ((d, c), (b, a)))))
+    (fun ((j, i), (((h, g), (f, e)), ((d, c), (b, a)))) ->
+       (j, i, h, g, f, e, d, c, b, a))
+    ty
+let obj10 f10 f9 f8 f7 f6 f5 f4 f3 f2 f1 =
+  conv10 (obj10 f10 f9 f8 f7 f6 f5 f4 f3 f2 f1)
+let tup10 f10 f9 f8 f7 f6 f5 f4 f3 f2 f1 =
+  conv10 (tup10 f10 f9 f8 f7 f6 f5 f4 f3 f2 f1)
+
+let check_cases tag_size cases =
+  if cases = [] then
+    invalid_arg "Data_encoding.union: empty list of cases." ;
+  let max_tag =
+    match tag_size with
+    | `Uint8 -> 256
+    | `Uint16 -> 256 * 256 in
+  ignore @@
+  List.fold_left
+    (fun others (Case { tag }) ->
+       match tag with
+       | Json_only -> others
+       | Tag tag ->
+           if List.mem tag others then raise (Duplicated_tag tag) ;
+           if tag < 0 || max_tag <= tag then
+             raise (Invalid_tag (tag, tag_size)) ;
+           tag :: others
+    )
+    [] cases
+
+let union ?(tag_size = `Uint8) cases =
+  check_cases tag_size cases ;
+  let kinds =
+    List.map (fun (Case { encoding }) -> classify encoding) cases in
+  let kind = Kind.merge_list tag_size kinds in
+  make @@ Union (kind, tag_size, cases)
+let case ?name tag encoding proj inj = Case { name ; encoding ; proj ; inj ; tag }
+let option ty =
+  union
+    ~tag_size:`Uint8
+    [ case (Tag 1) ty
+        ~name:"Some"
+        (fun x -> x)
+        (fun x -> Some x) ;
+      case (Tag 0) empty
+        ~name:"None"
+        (function None -> Some () | Some _ -> None)
+        (fun () -> None) ;
+    ]
+let mu name self =
+  let kind =
+    try
+      match classify (self (make @@ Mu (`Dynamic, name, self))) with
+      | `Fixed _ | `Dynamic -> `Dynamic
+      | `Variable -> raise Exit
+    with Exit | _ (* TODO variability error *) ->
+      ignore @@ classify (self (make @@ Mu (`Variable, name, self))) ;
+      `Variable in
+  make @@ Mu (kind, name, self)
+
+let result ok_enc error_enc =
+  union
+    ~tag_size:`Uint8
+    [ case (Tag 1) ok_enc
+        (function Ok x -> Some x | Error _ -> None)
+        (fun x -> Ok x) ;
+      case (Tag 0) error_enc
+        (function Ok _ -> None | Error x -> Some x)
+        (fun x -> Error x) ;
+    ]
+

src/lib_data_encoding/encoding.mli

@@ -0,0 +1,489 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2018.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Type-safe serialization and deserialization of data structures. *)
+
+(** {1 Data Encoding} *)
+
+(** This module provides type-safe serialization and deserialization of
+    data structures. Backends are provided to both binary and JSON.
+
+    This works by writing type descriptors by hand, using the provided
+    combinators. These combinators can fine-tune the binary
+    representation to be compact and efficient, but also provide
+    proper field names and meta information, so the API of Tezos can
+    be automatically introspected and documented.
+
+    Here is an example encoding for type [(int * string)].
+
+    [let enc = obj2 (req "code" uint16) (req "message" string)]
+
+    In JSON, this encoding maps values of type [int * string] to JSON
+    objects with a field [code] whose value is a number and a field
+    [message] whose value is a string.
+
+    In binary, this encoding maps to two raw bytes for the [int]
+    followed by the size of the string in bytes, and finally the raw
+    contents of the string. This binary format is mostly tagless,
+    meaning that serialized data cannot be interpreted without the
+    encoding that was used for serialization.
+
+    Regarding binary serialization, encodings are classified as either:
+    - fixed size (booleans, integers, numbers)
+      data is always the same size for that type ;
+    - dynamically sized (arbitrary strings and bytes)
+      data is of unknown size and requires an explicit length field ;
+    - variable size (special case of strings, bytes, and arrays)
+      data makes up the remainder of an object of known size,
+      thus its size is given by the context, and does not
+      have to be serialized.
+
+    JSON operations are delegated to [ocplib-json-typed]. *)
+
+(* TODO: reorder all the functions so it makes sense (ground, combinator,
+ * predicates, etc.) *)
+(* TODO: move the doc into the packing module *)
+
+module Size: sig
+  val bool: int
+  val int8: int
+  val uint8: int
+  val char: int
+  val int16: int
+  val uint16: int
+  val uint30: int
+  val uint32: int
+  val uint64: int
+  val int31: int
+  val int32: int
+  val int64: int
+  val float: int
+end
+
+type tag_size = [ `Uint8 | `Uint16 ]
+
+val tag_size: tag_size -> int
+
+val apply: ?error:exn -> ('a -> 'b option) list -> 'a -> 'b
+
+module Kind: sig
+
+  type t = [ `Fixed of int | `Dynamic | `Variable ]
+
+  type length = [ `Fixed of int | `Variable ]
+
+  type enum = [ `Dynamic | `Variable ]
+
+  val combine: string -> t -> t -> t
+
+  val merge : t -> t -> t
+
+  val merge_list: tag_size -> t list -> t
+
+end
+
+type case_tag = Tag of int | Json_only
+
+type 'a desc =
+  | Null : unit desc
+  | Empty : unit desc
+  | Ignore : unit desc
+  | Constant : string -> unit desc
+  | Bool : bool desc
+  | Int8 : int desc
+  | Uint8 : int desc
+  | Int16 : int desc
+  | Uint16 : int desc
+  | Int31 : int desc
+  | Int32 : Int32.t desc
+  | Int64 : Int64.t desc
+  | RangedInt : { minimum : int ; maximum : int } -> int desc
+  | RangedFloat : { minimum : float ; maximum : float } -> float desc
+  | Float : float desc
+  | Bytes : Kind.length -> MBytes.t desc
+  | String : Kind.length -> string desc
+  | String_enum : ('a, string * int) Hashtbl.t * 'a array -> 'a desc
+  | Array : 'a t -> 'a array desc
+  | List : 'a t -> 'a list desc
+  | Obj : 'a field -> 'a desc
+  | Objs : Kind.t * 'a t * 'b t -> ('a * 'b) desc
+  | Tup : 'a t -> 'a desc
+  | Tups : Kind.t * 'a t * 'b t -> ('a * 'b) desc
+  | Union : Kind.t * tag_size * 'a case list -> 'a desc
+  | Mu : Kind.enum * string * ('a t -> 'a t) -> 'a desc
+  | Conv :
+      { proj : ('a -> 'b) ;
+        inj : ('b -> 'a) ;
+        encoding : 'b t ;
+        schema : Json_schema.schema option } -> 'a desc
+  | Describe :
+      { title : string option ;
+        description : string option ;
+        encoding : 'a t } -> 'a desc
+  | Def : { name : string ;
+            encoding : 'a t } -> 'a desc
+  | Splitted :
+      { encoding : 'a t ;
+        json_encoding : 'a Json_encoding.encoding ;
+        is_obj : bool ; is_tup : bool } -> 'a desc
+  | Dynamic_size : 'a t -> 'a desc
+  | Delayed : (unit -> 'a t) -> 'a desc
+
+and _ field =
+  | Req : string * 'a t -> 'a field
+  | Opt : Kind.enum * string * 'a t -> 'a option field
+  | Dft : string * 'a t * 'a -> 'a field
+
+and 'a case =
+  | Case : { name : string option ;
+             encoding : 'a t ;
+             proj : ('t -> 'a option) ;
+             inj : ('a -> 't) ;
+             tag : case_tag } -> 't case
+
+and 'a t = {
+  encoding: 'a desc ;
+  mutable json_encoding: 'a Json_encoding.encoding option ;
+}
+type 'a encoding = 'a t
+
+val make: ?json_encoding: 'a Json_encoding.encoding -> 'a desc -> 'a t
+
+type signed_integer = [ `Int31 | `Int16 | `Int8 ]
+type unsigned_integer = [ `Uint30 | `Uint16 | `Uint8 ]
+type integer = [ signed_integer | unsigned_integer ]
+val integer_to_size: integer -> int
+val range_to_size: minimum:int -> maximum:int -> integer
+val enum_size: 'a array -> [> unsigned_integer ]
+
+
+exception No_case_matched
+exception Unexpected_tag of int
+exception Duplicated_tag of int
+exception Invalid_tag of int * [ `Uint8 | `Uint16 ]
+exception Unexpected_enum of string * string list
+exception Parse_error of string
+exception Float_out_of_range of float * float * float
+exception Int_out_of_range of int * int * int
+exception Invalid_size of int
+
+
+(** Special value [null] in JSON, nothing in binary. *)
+val null : unit encoding
+
+(** Empty object (not included in binary, encoded as empty object in JSON). *)
+val empty : unit encoding
+
+(** Unit value, ommitted in binary.
+    Serialized as an empty object in JSON, accepts any object when deserializing. *)
+val unit : unit encoding
+
+(** Constant string (data is not included in the binary data). *)
+val constant : string -> unit encoding
+
+(** Signed 8 bit integer
+    (data is encoded as a byte in binary and an integer in JSON). *)
+val int8 : int encoding
+
+(** Unsigned 8 bit integer
+    (data is encoded as a byte in binary and an integer in JSON). *)
+val uint8 : int encoding
+
+(** Signed 16 bit integer
+    (data is encoded as a short in binary and an integer in JSON). *)
+val int16 : int encoding
+
+(** Unsigned 16 bit integer
+    (data is encoded as a short in binary and an integer in JSON). *)
+val uint16 : int encoding
+
+(** Signed 31 bit integer, which corresponds to type int on 32-bit OCaml systems
+    (data is encoded as a 32 bit int in binary and an integer in JSON). *)
+val int31 : int encoding
+
+(** Signed 32 bit integer
+    (data is encoded as a 32-bit int in binary and an integer in JSON). *)
+val int32 : int32 encoding
+
+(** Signed 64 bit integer
+    (data is encodedas a 64-bit int in binary and a decimal string in JSON). *)
+val int64 : int64 encoding
+
+(** Integer with bounds in a given range. Both bounds are inclusive.
+
+    Raises [Invalid_argument] if the bounds are beyond the interval
+    [-2^30; 2^30-1]. These bounds are chosen to be compatible with all versions
+    of OCaml.
+*)
+val ranged_int : int -> int -> int encoding
+
+(** Float with bounds in a given range. Both bounds are inclusive *)
+val ranged_float : float -> float -> float encoding
+
+(** Encoding of a boolean
+    (data is encoded as a byte in binary and a boolean in JSON). *)
+val bool : bool encoding
+
+(** Encoding of a string
+    - default variable in width
+    - encoded as a byte sequence in binary
+    - encoded as a string in JSON. *)
+val string : string encoding
+
+(** Encoding of arbitrary bytes
+    (encoded via hex in JSON and directly as a sequence byte in binary). *)
+val bytes : MBytes.t encoding
+
+(** Encoding of floating point number
+    (encoded as a floating point number in JSON and a double in binary). *)
+val float : float encoding
+
+(** Combinator to make an optional value
+    (represented as a 1-byte tag followed by the data (or nothing) in binary
+     and either the raw value or an empty object in JSON). *)
+val option : 'a encoding -> 'a option encoding
+
+(** Combinator to make a {!result} value
+    (represented as a 1-byte tag followed by the data of either type in binary,
+     and either unwrapped value in JSON (the caller must ensure that both
+     encodings do not collide)). *)
+val result : 'a encoding -> 'b encoding -> ('a, 'b) result encoding
+
+(** Encode enumeration via association list
+    (represented as a string in JSON and binary). *)
+val string_enum : (string * 'a) list -> 'a encoding
+
+
+(** Is the given encoding serialized as a JSON object? *)
+val is_obj : 'a encoding -> bool
+
+(** Does the given encoding encode a tuple? *)
+val is_tup : 'a encoding -> bool
+
+(** Create encodings that produce data of a fixed length when binary encoded.
+    See the preamble for an explanation. *)
+module Fixed : sig
+
+  (** Encode a fixed length string *)
+  val string : int -> string encoding
+
+  (** Encode a fixed length byte sequence *)
+  val bytes : int -> MBytes.t encoding
+end
+
+(** Create encodings that produce data of a variable length when binary encoded.
+    See the preamble for an explanation. *)
+module Variable : sig
+  (** Encode a string *)
+  val string : string encoding
+
+  (** Encode a byte sequence *)
+  val bytes : MBytes.t encoding
+
+  (** Array encoding combinator *)
+  val array : 'a encoding -> 'a array encoding
+
+  (** List encoding combinator *)
+  val list : 'a encoding -> 'a list encoding
+end
+
+(** Mark an encoding as being of dynamic size.
+    Forces the size to be stored alongside content when needed.
+    Usually used to fix errors from combining two encodings. *)
+val dynamic_size : 'a encoding -> 'a encoding
+
+(** Recompute the encoding definition each time it is used.
+    Useful for dynamically updating the encoding of values of an extensible
+    type via a global reference (e.g. exceptions). *)
+val delayed : (unit -> 'a encoding) -> 'a encoding
+
+(** Required field. *)
+val req :
+  ?title:string -> ?description:string ->
+  string -> 't encoding -> 't field
+
+(** Optional field. Omitted entirely in JSON encoding if None.
+    Omitted in binary if the only optional field in a [`Variable]
+    encoding, otherwise a 1-byte prefix (`0` or `1`) tells if the
+    field is present or not. *)
+val opt :
+  ?title:string -> ?description:string ->
+  string -> 't encoding -> 't option field
+
+(** Optional field of variable length.
+    Only one can be present in a given object. *)
+val varopt :
+  ?title:string -> ?description:string ->
+  string -> 't encoding -> 't option field
+
+(** Required field with a default value.
+    If the default value is passed, the field is omitted in JSON.
+    The value is always serialized in binary. *)
+val dft :
+  ?title:string -> ?description:string ->
+  string -> 't encoding -> 't -> 't field
+
+(** {2 Constructors for objects with N fields} *)
+
+(** These are serialized to binary by converting each internal object to binary
+    and placing them in the order of the original object.
+    These are serialized to JSON as a JSON object with the field names. *)
+
+val obj1 :
+  'f1 field -> 'f1 encoding
+val obj2 :
+  'f1 field -> 'f2 field -> ('f1 * 'f2) encoding
+val obj3 :
+  'f1 field -> 'f2 field -> 'f3 field -> ('f1 * 'f2 * 'f3) encoding
+val obj4 :
+  'f1 field -> 'f2 field -> 'f3 field -> 'f4 field ->
+  ('f1 * 'f2 * 'f3 * 'f4) encoding
+val obj5 :
+  'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> 'f5 field ->
+  ('f1 * 'f2 * 'f3 * 'f4 * 'f5) encoding
+val obj6 :
+  'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> 'f5 field ->
+  'f6 field ->
+  ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6) encoding
+val obj7 :
+  'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> 'f5 field ->
+  'f6 field -> 'f7 field ->
+  ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7) encoding
+val obj8 :
+  'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> 'f5 field ->
+  'f6 field -> 'f7 field -> 'f8 field ->
+  ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8) encoding
+val obj9 :
+  'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> 'f5 field ->
+  'f6 field -> 'f7 field -> 'f8 field -> 'f9 field ->
+  ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9) encoding
+val obj10 :
+  'f1 field -> 'f2 field -> 'f3 field -> 'f4 field -> 'f5 field ->
+  'f6 field -> 'f7 field -> 'f8 field -> 'f9 field -> 'f10 field ->
+  ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9 * 'f10) encoding
+
+(** {2 Constructors for tuples with N fields} *)
+
+(** These are serialized to binary by converting each internal object to binary
+    and placing them in the order of the original object.
+    These are serialized to JSON as JSON arrays/lists. *)
+
+val tup1 :
+  'f1 encoding ->
+  'f1 encoding
+val tup2 :
+  'f1 encoding -> 'f2 encoding ->
+  ('f1 * 'f2) encoding
+val tup3 :
+  'f1 encoding -> 'f2 encoding -> 'f3 encoding ->
+  ('f1 * 'f2 * 'f3) encoding
+val tup4 :
+  'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding ->
+  ('f1 * 'f2 * 'f3 * 'f4) encoding
+val tup5 :
+  'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding ->
+  'f5 encoding ->
+  ('f1 * 'f2 * 'f3 * 'f4 * 'f5) encoding
+val tup6 :
+  'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding ->
+  'f5 encoding -> 'f6 encoding ->
+  ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6) encoding
+val tup7 :
+  'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding ->
+  'f5 encoding -> 'f6 encoding -> 'f7 encoding ->
+  ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7) encoding
+val tup8 :
+  'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding ->
+  'f5 encoding -> 'f6 encoding -> 'f7 encoding -> 'f8 encoding ->
+  ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8) encoding
+val tup9 :
+  'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding ->
+  'f5 encoding -> 'f6 encoding -> 'f7 encoding -> 'f8 encoding ->
+  'f9 encoding ->
+  ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9) encoding
+val tup10 :
+  'f1 encoding -> 'f2 encoding -> 'f3 encoding -> 'f4 encoding ->
+  'f5 encoding -> 'f6 encoding -> 'f7 encoding -> 'f8 encoding ->
+  'f9 encoding -> 'f10 encoding ->
+  ('f1 * 'f2 * 'f3 * 'f4 * 'f5 * 'f6 * 'f7 * 'f8 * 'f9 * 'f10) encoding
+
+(** {2 Combinators} *)
+
+(** Create a larger object from the encodings of two smaller ones.
+    @raise invalid_arg if both arguments are not objects. *)
+val merge_objs : 'o1 encoding -> 'o2 encoding -> ('o1 * 'o2) encoding
+
+(** Create a large tuple encoding from two smaller ones.
+    @raise invalid_arg if both values are not tuples. *)
+val merge_tups : 'a1 encoding -> 'a2 encoding -> ('a1 * 'a2) encoding
+
+(** Array combinator. *)
+val array : 'a encoding -> 'a array encoding
+
+(** List combinator. *)
+val list : 'a encoding -> 'a list encoding
+
+(** Encodes a variant constructor. Takes the encoding for the specific
+    parameters, a recognizer function that will extract the parameters
+    in case the expected case of the variant is being serialized, and
+    a constructor function for deserialization.
+
+    The tag must be less than the tag size of the union in which you use the case.
+    An optional tag gives a name to a case and should be used to maintain
+    compatibility.
+
+    An optional name for the case can be provided,
+    which is used in the binary documentation. *)
+val case :
+  ?name:string ->
+  case_tag ->
+  'a encoding -> ('t -> 'a option) -> ('a -> 't) -> 't case
+
+(** Create a single encoding from a series of cases.
+
+    In JSON, all cases are tried one after the other. The caller must
+    check for collisions.
+
+    In binary, a prefix tag is added to discriminate quickly between
+    cases. The default is `Uint8 and you must use a `Uint16 if you are
+    going to have more than 256 cases.
+
+    This function will raise an exception if it is given the empty list
+    or if there are more cases than can fit in the tag size. *)
+val union :
+  ?tag_size:[ `Uint8 | `Uint16 ] -> 't case list -> 't encoding
+
+(** Add documentation to an encoding. *)
+val describe :
+  ?title:string -> ?description:string ->
+  't encoding ->'t encoding
+
+(** Give a name to an encoding. *)
+val def : string -> 'a encoding -> 'a encoding
+
+(** Provide a transformer from one encoding to a different one.
+
+    Used to simplify nested encodings or to change the generic tuples
+    built by {obj1}, {tup1} and the like into proper records.
+
+    A schema may optionally be provided as documentation of the new encoding. *)
+val conv :
+  ('a -> 'b) -> ('b -> 'a) ->
+  ?schema:Json_schema.schema ->
+  'b encoding -> 'a encoding
+
+(** Combinator for recursive encodings. *)
+val mu : string -> ('a encoding -> 'a encoding) -> 'a encoding
+
+(** Classify an encoding wrt. its binary serialization as explained in the preamble. *)
+val classify : 'a encoding -> [ `Fixed of int | `Dynamic | `Variable ]
+
+(** Define different encodings for JSON and binary serialization. *)
+val raw_splitted : json:'a Json_encoding.encoding -> binary:'a encoding -> 'a encoding
+

src/lib_data_encoding/json.ml

@@ -0,0 +1,277 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2018.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Encoding (* TODO: unopen *)
+
+
+type json =
+  [ `O of (string * json) list
+  | `Bool of bool
+  | `Float of float
+  | `A of json list
+  | `Null
+  | `String of string ]
+
+type schema = Json_schema.schema
+
+type pair_builder = {
+  build: 'a 'b. Kind.t -> 'a t -> 'b t -> ('a * 'b) t
+}
+
+exception Parse_error of string
+
+let wrap_error f =
+  fun str ->
+    try f str
+    with exn -> raise (Json_encoding.Cannot_destruct ([], exn))
+
+let int64_encoding =
+  let open Json_encoding in
+  union [
+    case
+      int32
+      (fun i ->
+         let j = Int64.to_int32 i in
+         if Int64.equal (Int64.of_int32 j) i then Some j else None)
+      Int64.of_int32 ;
+    case
+      string
+      (fun i -> Some (Int64.to_string i))
+      Int64.of_string
+  ]
+
+let bytes_jsont =
+  let open Json_encoding in
+  let schema =
+    let open Json_schema in
+    create
+      { title = None ;
+        description = None ;
+        default = None;
+        enum = None;
+        kind = String {
+            pattern = Some "^[a-zA-Z0-9]+$";
+            min_length = 0;
+            max_length = None;
+          };
+        format = None ;
+        id = None } in
+  conv ~schema
+    MBytes.to_hex
+    (wrap_error MBytes.of_hex)
+    (conv
+       (fun (`Hex h) -> h)
+       (fun h -> `Hex h)
+       string)
+
+let rec lift_union : type a. a t -> a t = fun e ->
+  match e.encoding with
+  | Conv { proj ; inj ; encoding = e ; schema } -> begin
+      match lift_union e with
+      | { encoding = Union (kind, tag, cases) } ->
+          make @@
+          Union (kind, tag,
+                 List.map
+                   (fun (Case { name ; encoding ; proj = proj' ; inj = inj' ; tag }) ->
+                      Case { encoding ;
+                             name ;
+                             proj = (fun x -> proj' (proj x));
+                             inj = (fun x -> inj (inj' x)) ;
+                             tag })
+                   cases)
+      | e -> make @@ Conv { proj ; inj ; encoding = e ; schema }
+    end
+  | Objs (p, e1, e2) ->
+      lift_union_in_pair
+        { build = fun p e1 e2 -> make @@ Objs (p, e1, e2) }
+        p e1 e2
+  | Tups (p, e1, e2) ->
+      lift_union_in_pair
+        { build = fun p e1 e2 -> make @@ Tups (p, e1, e2) }
+        p e1 e2
+  | _ -> e
+
+and lift_union_in_pair
+  : type a b. pair_builder -> Kind.t -> a t -> b t -> (a * b) t
+  = fun b p e1 e2 ->
+    match lift_union e1, lift_union e2 with
+    | e1, { encoding = Union (_kind, tag, cases) } ->
+        make @@
+        Union (`Dynamic (* ignored *), tag,
+               List.map
+                 (fun (Case { name ; encoding = e2 ; proj ; inj ; tag }) ->
+                    Case { encoding = lift_union_in_pair b p e1 e2 ;
+                           name ;
+                           proj = (fun (x, y) ->
+                               match proj y with
+                               | None -> None
+                               | Some y -> Some (x, y)) ;
+                           inj = (fun (x, y) -> (x, inj y)) ;
+                           tag })
+                 cases)
+    | { encoding = Union (_kind, tag, cases) }, e2 ->
+        make @@
+        Union (`Dynamic (* ignored *), tag,
+               List.map
+                 (fun (Case { name ; encoding = e1 ; proj ; inj ; tag }) ->
+                    Case { encoding = lift_union_in_pair b p e1 e2 ;
+                           name ;
+                           proj = (fun (x, y) ->
+                               match proj x with
+                               | None -> None
+                               | Some x -> Some (x, y)) ;
+                           inj = (fun (x, y) -> (inj x, y)) ;
+                           tag })
+                 cases)
+    | e1, e2 -> b.build p e1 e2
+
+let rec json : type a. a desc -> a Json_encoding.encoding =
+  let open Json_encoding in
+  function
+  | Null -> null
+  | Empty -> empty
+  | Constant s -> constant s
+  | Ignore -> unit
+  | Int8 -> ranged_int ~minimum:~-(1 lsl 7) ~maximum:((1 lsl 7) - 1) "int8"
+  | Uint8 -> ranged_int ~minimum:0 ~maximum:((1 lsl 8) - 1) "uint8"
+  | Int16 -> ranged_int ~minimum:~-(1 lsl 15) ~maximum:((1 lsl 15) - 1) "int16"
+  | Uint16 -> ranged_int ~minimum:0 ~maximum:((1 lsl 16) - 1) "uint16"
+  | RangedInt { minimum ; maximum } -> ranged_int ~minimum ~maximum "rangedInt"
+  | Int31 -> int
+  | Int32 -> int32
+  | Int64 -> int64_encoding
+  | Bool -> bool
+  | Float -> float
+  | RangedFloat { minimum; maximum } -> ranged_float ~minimum ~maximum "rangedFloat"
+  | String _ -> string (* TODO: check length *)
+  | Bytes _ -> bytes_jsont (* TODO check length *)
+  | String_enum (tbl, _) -> string_enum (Hashtbl.fold (fun a (str, _) acc -> (str, a) :: acc) tbl [])
+  | Array e -> array (get_json e)
+  | List e -> list (get_json e)
+  | Obj f -> obj1 (field_json f)
+  | Objs (_, e1, e2) ->
+      merge_objs (get_json e1) (get_json e2)
+  | Tup e -> tup1 (get_json e)
+  | Tups (_, e1, e2) ->
+      merge_tups (get_json e1) (get_json e2)
+  | Conv { proj ; inj ; encoding = e ; schema } -> conv ?schema proj inj (get_json e)
+  | Describe { title ; description ; encoding = e } ->
+      describe ?title ?description (get_json e)
+  | Def { name ; encoding = e } -> def name (get_json e)
+  | Mu (_, name, self) as ty ->
+      mu name (fun json_encoding -> get_json @@ self (make ~json_encoding ty))
+  | Union (_tag_size, _, cases) -> union (List.map case_json cases)
+  | Splitted { json_encoding } -> json_encoding
+  | Dynamic_size e -> get_json e
+  | Delayed f -> get_json (f ())
+
+and field_json
+  : type a. a field -> a Json_encoding.field =
+  let open Json_encoding in
+  function
+  | Req (name, e) -> req name (get_json e)
+  | Opt (_, name, e) -> opt name (get_json e)
+  | Dft (name, e, d) -> dft name (get_json e) d
+
+and case_json : type a. a case -> a Json_encoding.case =
+  let open Json_encoding in
+  function
+  | Case { encoding = e ; proj ; inj ; _ } -> case (get_json e) proj inj
+
+and get_json : type a. a t -> a Json_encoding.encoding = fun e ->
+  match e.json_encoding with
+  | None ->
+      let json_encoding = json (lift_union e).encoding in
+      e.json_encoding <- Some json_encoding ;
+      json_encoding
+  | Some json_encoding -> json_encoding
+
+let convert = get_json
+
+type path = path_item list
+and path_item =
+  [ `Field of string
+  (** A field in an object. *)
+  | `Index of int
+  (** An index in an array. *)
+  | `Star
+  (** Any / every field or index. *)
+  | `Next
+    (** The next element after an array. *) ]
+
+include Json_encoding
+
+let construct e v = construct (get_json e) v
+let destruct e v = destruct (get_json e) v
+let schema e = schema (get_json e)
+
+let cannot_destruct fmt =
+  Format.kasprintf
+    (fun msg -> raise (Cannot_destruct ([], Failure msg)))
+    fmt
+
+type t = json
+
+let to_root = function
+  | `O ctns -> `O ctns
+  | `A ctns -> `A ctns
+  | `Null -> `O []
+  | oth -> `A [ oth ]
+
+let to_string ?minify j = Ezjsonm.to_string ?minify (to_root j)
+
+let pp = Json_repr.(pp (module Ezjsonm))
+
+let from_string s =
+  try Ok (Ezjsonm.from_string s :> json)
+  with Ezjsonm.Parse_error (_, msg) -> Error msg
+
+let from_stream (stream: string Lwt_stream.t) =
+  let buffer = ref "" in
+  Lwt_stream.filter_map
+    (fun str ->
+       buffer := !buffer ^ str ;
+       try
+         let json = Ezjsonm.from_string !buffer in
+         buffer := "" ;
+         Some (Ok json)
+       with Ezjsonm.Parse_error _ ->
+         None)
+    stream
+
+let encoding =
+  let binary : Json_repr.ezjsonm Encoding.t =
+    Encoding.conv
+      (fun json ->
+         Json_repr.convert
+           (module Json_repr.Ezjsonm)
+           (module Json_repr_bson.Repr)
+           json |>
+         Json_repr_bson.bson_to_bytes |>
+         Bytes.to_string)
+      (fun s -> try
+          Bytes.of_string s |>
+          Json_repr_bson.bytes_to_bson ~copy:false |>
+          Json_repr.convert
+            (module Json_repr_bson.Repr)
+            (module Json_repr.Ezjsonm)
+        with
+        | Json_repr_bson.Bson_decoding_error (msg, _, _) ->
+            raise (Parse_error msg))
+      Encoding.string in
+  let json =
+    Json_encoding.any_ezjson_value in
+  raw_splitted ~binary ~json
+
+let schema_encoding =
+  Encoding.conv
+    Json_schema.to_json
+    Json_schema.of_json
+    encoding
+

src/lib_data_encoding/json.mli

@@ -0,0 +1,96 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2018.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Type-safe serialization and deserialization of data structures. *)
+
+(** In memory JSON data, compatible with [Ezjsonm]. *)
+type json =
+  [ `O of (string * json) list
+  | `Bool of bool
+  | `Float of float
+  | `A of json list
+  | `Null
+  | `String of string ]
+type t = json
+
+type schema = Json_schema.schema
+
+
+(** Create a {!Json_encoding.encoding} from an {encoding}. *)
+val convert : 'a Encoding.t -> 'a Json_encoding.encoding
+
+(** Generate a schema from an {!encoding}. *)
+val schema : 'a Encoding.t -> schema
+
+val encoding: json Encoding.t
+val schema_encoding: schema Encoding.t
+
+
+(** Construct a JSON object from an encoding. *)
+val construct : 't Encoding.t -> 't -> json
+
+(** Destruct a JSON object into a value.
+    Fail with an exception if the JSON object and encoding do not match.. *)
+val destruct : 't Encoding.t -> json -> 't
+
+(** JSON Error. *)
+
+type path = path_item list
+
+(** A set of accessors that point to a location in a JSON object. *)
+and path_item =
+  [ `Field of string
+  (** A field in an object. *)
+  | `Index of int
+  (** An index in an array. *)
+  | `Star
+  (** Any / every field or index. *)
+  | `Next
+    (** The next element after an array. *) ]
+
+(** Exception raised by destructors, with the location in the original
+    JSON structure and the specific error. *)
+exception Cannot_destruct of (path * exn)
+
+(** Unexpected kind of data encountered (w/ the expectation). *)
+exception Unexpected of string * string
+
+(** Some {!union} couldn't be destructed, w/ the reasons for each {!case}. *)
+exception No_case_matched of exn list
+
+(** Array of unexpected size encountered  (w/ the expectation). *)
+exception Bad_array_size of int * int
+
+(** Missing field in an object. *)
+exception Missing_field of string
+
+(** Supernumerary field in an object. *)
+exception Unexpected_field of string
+
+val print_error :
+  ?print_unknown: (Format.formatter -> exn -> unit) ->
+  Format.formatter -> exn -> unit
+
+(** Helpers for writing encoders. *)
+val cannot_destruct : ('a, Format.formatter, unit, 'b) format4 -> 'a
+val wrap_error : ('a -> 'b) -> 'a -> 'b
+
+(** Read a JSON document from a string. *)
+val from_string : string -> (json, string) result
+
+(** Read a stream of JSON documents from a stream of strings.
+    A single JSON document may be represented in multiple consecutive
+    strings. But only the first document of a string is considered. *)
+val from_stream : string Lwt_stream.t -> (json, string) result Lwt_stream.t
+
+(** Write a JSON document to a string. This goes via an intermediate
+    buffer and so may be slow on large documents. *)
+val to_string : ?minify:bool -> json -> string
+
+val pp : Format.formatter -> json -> unit