Data_encoding: split out Binary_length

src/lib_data_encoding/binary.ml

@@ -20,116 +20,6 @@ type 'l writer = {
   write: 'a. 'a Encoding.t -> 'a -> MBytes.t -> int -> int ;
 }
 
-let rec length : type x. x Encoding.t -> x -> int = fun e ->
-  let open Encoding in
-  match e.encoding with
-  (* Fixed *)
-  | Null -> fun _ -> 0
-  | Empty -> fun _ -> 0
-  | Constant _ -> fun _ -> 0
-  | Bool -> fun _ -> Binary_size.bool
-  | Int8 -> fun _ -> Binary_size.int8
-  | Uint8 -> fun _ -> Binary_size.uint8
-  | Int16 -> fun _ -> Binary_size.int16
-  | Uint16 -> fun _ -> Binary_size.uint16
-  | Int31 -> fun _ -> Binary_size.int31
-  | Int32 -> fun _ -> Binary_size.int32
-  | Int64 -> fun _ -> Binary_size.int64
-  | Z -> fun z -> (Z.numbits z + 1 + 6) / 7
-  | RangedInt { minimum ; maximum } ->
-      fun _ -> Binary_size.(integer_to_size @@ range_to_size ~minimum ~maximum)
-  | Float -> fun _ -> Binary_size.float
-  | RangedFloat _ -> fun _ -> Binary_size.float
-  | Bytes `Fixed n -> fun _ -> n
-  | String `Fixed n -> fun _ -> n
-  | String_enum (_, arr) ->
-      fun _ -> Binary_size.(integer_to_size @@ enum_size arr)
-  | Objs (`Fixed n, _, _) -> fun _ -> n
-  | Tups (`Fixed n, _, _) -> fun _ -> n
-  | Union (`Fixed n, _, _) -> fun _ -> n
-  (* Dynamic *)
-  | Objs (`Dynamic, e1, e2) ->
-      let length1 = length e1 in
-      let length2 = length e2 in
-      fun (v1, v2) -> length1 v1 + length2 v2
-  | Tups (`Dynamic, e1, e2) ->
-      let length1 = length e1 in
-      let length2 = length e2 in
-      fun (v1, v2) -> length1 v1 + length2 v2
-  | Union (`Dynamic, sz, cases) ->
-      let tag_size = Binary_size.tag_size sz in
-      let case_length (Case { encoding = e ; proj }) =
-        let length v = tag_size + length e v in
-        fun v -> Option.map ~f:length (proj v) in
-      apply_and_get_first_some (List.map case_length cases)
-  | Mu (`Dynamic, _name, self) ->
-      fun v -> length (self e) v
-  | Obj (Opt (`Dynamic, _, e)) ->
-      let length = length e in
-      (function None -> 1 | Some x -> 1 + length x)
-  (* Variable *)
-  | Ignore -> fun _ -> 0
-  | Bytes `Variable -> MBytes.length
-  | String `Variable -> String.length
-  | Array e ->
-      let length = length e in
-      fun v ->
-        Array.fold_left
-          (fun acc v -> length v + acc)
-          0 v
-  | List e ->
-      let length = length e in
-      fun v ->
-        List.fold_left
-          (fun acc v -> length v + acc)
-          0 v
-  | Objs (`Variable, e1, e2) ->
-      let length1 = length e1 in
-      let length2 = length e2 in
-      fun (v1, v2) -> length1 v1 + length2 v2
-  | Tups (`Variable, e1, e2) ->
-      let length1 = length e1
-      and length2 = length e2 in
-      fun (v1, v2) -> length1 v1 + length2 v2
-  | Obj (Opt (`Variable, _, e)) ->
-      let length = length e in
-      (function None -> 0 | Some x -> length x)
-  | Union (`Variable, sz, cases) ->
-      let rec case_lengths json_only_cases acc = function
-        | [] -> (List.rev acc, json_only_cases)
-        | Case { tag = Json_only } :: tl -> case_lengths true acc tl
-        | Case { encoding = e ; proj ; tag = Tag _ } :: tl ->
-            let length v = Binary_size.tag_size sz + length e v in
-            case_lengths
-              json_only_cases
-              ((fun v ->
-                  match proj v with
-                  | None -> None
-                  | Some v -> Some (length v)) :: acc)
-              tl in
-      let cases, json_only = case_lengths false [] cases in
-      apply_and_get_first_some
-        ~error:(if json_only
-                then Failure "No case matched, but JSON only cases were present in union"
-                else No_case_matched)
-        cases
-  | Mu (`Variable, _name, self) ->
-      fun v -> length (self e) v
-  (* Recursive*)
-  | Obj (Req (_, e)) -> length e
-  | Obj (Dft (_, e, _)) -> length e
-  | Tup e -> length e
-  | Conv  { encoding = e ; proj } ->
-      let length = length e in
-      fun v -> length (proj v)
-  | Describe { encoding = e } -> length e
-  | Def { encoding = e } -> length e
-  | Splitted { encoding = e } -> length e
-  | Dynamic_size e ->
-      let length = length e in
-      fun v -> Binary_size.int32 + length v
-  | Delayed f -> length (f ())
-
 (** Writer *)
 
 module Writer = struct
@@ -428,7 +318,7 @@ let rec write_rec
   | Union (_, sz, cases) -> union { write = write_rec } sz cases
   | Mu (_, _, self) -> fun v buf ofs -> write_rec (self e) v buf ofs
   | Dynamic_size e ->
-      let length = length e
+      let length = Binary_length.length e
       and write = write_rec e in
       fun v buf ofs ->
         int32 (Int32.of_int @@ length v) buf ofs |> write v buf
@@ -542,10 +432,6 @@ let to_bytes t v =
   write_rec_buffer t v bytes ;
   MBytes_buffer.to_mbytes bytes
 
-let to_bytes = to_bytes
-
-let length = length
-
 let fixed_length e =
   match Encoding.classify e with
   | `Fixed n -> Some n

src/lib_data_encoding/binary.mli

@@ -10,8 +10,5 @@
 (** This is for use *within* the data encoding library only. Instead, you should
     use the corresponding module intended for use: {Data_encoding.Binary}. *)
 
-val length : 'a Encoding.t -> 'a -> int
 val write : 'a Encoding.t -> 'a -> MBytes.t -> int -> int option
 val to_bytes : 'a Encoding.t -> 'a -> MBytes.t
-val fixed_length : 'a Encoding.t -> int option
-val fixed_length_exn : 'a Encoding.t -> int

src/lib_data_encoding/binary_length.ml

@@ -0,0 +1,123 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2018.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Binary_error
+
+let rec length : type x. x Encoding.t -> x -> int =
+  fun e value ->
+    let open Encoding in
+    match e.encoding with
+    (* Fixed *)
+    | Null -> 0
+    | Empty -> 0
+    | Constant _ -> 0
+    | Bool -> Binary_size.bool
+    | Int8 -> Binary_size.int8
+    | Uint8 -> Binary_size.uint8
+    | Int16 -> Binary_size.int16
+    | Uint16 -> Binary_size.uint16
+    | Int31 -> Binary_size.int31
+    | Int32 -> Binary_size.int32
+    | Int64 -> Binary_size.int64
+    | Z -> (Z.numbits value + 1 + 6) / 7
+    | RangedInt { minimum ; maximum } ->
+        Binary_size.integer_to_size @@
+        Binary_size.range_to_size ~minimum ~maximum
+    | Float -> Binary_size.float
+    | RangedFloat _ -> Binary_size.float
+    | Bytes `Fixed n -> n
+    | String `Fixed n -> n
+    | String_enum (_, arr) ->
+        Binary_size.integer_to_size @@ Binary_size.enum_size arr
+    | Objs (`Fixed n, _, _) -> n
+    | Tups (`Fixed n, _, _) -> n
+    | Union (`Fixed n, _, _) -> n
+    (* Dynamic *)
+    | Objs (`Dynamic, e1, e2) ->
+        let (v1, v2) = value in
+        length e1 v1 + length e2 v2
+    | Tups (`Dynamic, e1, e2) ->
+        let (v1, v2) = value in
+        length e1 v1 + length e2 v2
+    | Union (`Dynamic, sz, cases) ->
+        let rec length_case = function
+          | [] -> raise (Read_error No_case_matched)
+          | Case { tag = Json_only } :: tl -> length_case tl
+          | Case { encoding = e ; proj ; _ } :: tl ->
+              match proj value with
+              | None -> length_case tl
+              | Some value ->
+                  let tag_size = Binary_size.tag_size sz in
+                  tag_size + length e value in
+        length_case cases
+    | Mu (`Dynamic, _name, self) ->
+        length (self e) value
+    | Obj (Opt (`Dynamic, _, e)) -> begin
+        match value with
+        | None -> 1
+        | Some value -> 1 + length e value
+      end
+    (* Variable *)
+    | Ignore -> 0
+    | Bytes `Variable -> MBytes.length value
+    | String `Variable -> String.length value
+    | Array e ->
+        Array.fold_left
+          (fun acc v -> length e v + acc)
+          0 value
+    | List e ->
+        List.fold_left
+          (fun acc v -> length e v + acc)
+          0 value
+    | Objs (`Variable, e1, e2) ->
+        let (v1, v2) = value in
+        length e1 v1 + length e2 v2
+    | Tups (`Variable, e1, e2) ->
+        let (v1, v2) = value in
+        length e1 v1 + length e2 v2
+    | Obj (Opt (`Variable, _, e)) -> begin
+        match value with
+        | None -> 0
+        | Some value -> length e value
+      end
+    | Union (`Variable, sz, cases) ->
+        let rec length_case = function
+          | [] -> raise (Read_error No_case_matched)
+          | Case { tag = Json_only } :: tl -> length_case tl
+          | Case { encoding = e ; proj ; _ } :: tl ->
+              match proj value with
+              | None -> length_case tl
+              | Some value ->
+                  let tag_size = Binary_size.tag_size sz in
+                  tag_size + length e value in
+        length_case cases
+    | Mu (`Variable, _name, self) ->
+        length (self e) value
+    (* Recursive*)
+    | Obj (Req (_, e)) -> length e value
+    | Obj (Dft (_, e, _)) -> length e value
+    | Tup e -> length e value
+    | Conv  { encoding = e ; proj } ->
+        length e (proj value)
+    | Describe { encoding = e } -> length e value
+    | Def { encoding = e } -> length e value
+    | Splitted { encoding = e } -> length e value
+    | Dynamic_size e ->
+        Binary_size.int32 + length e value
+    | Delayed f -> length (f ()) value
+
+let fixed_length e =
+  match Encoding.classify e with
+  | `Fixed n -> Some n
+  | `Dynamic | `Variable -> None
+let fixed_length_exn e =
+  match fixed_length e with
+  | Some n -> n
+  | None -> invalid_arg "Data_encoding.Binary.fixed_length_exn"
+

src/lib_data_encoding/binary_length.mli

@@ -0,0 +1,15 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2018.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** This is for use *within* the data encoding library only. Instead, you should
+    use the corresponding module intended for use: {Data_encoding.Binary}. *)
+
+val length : 'a Encoding.t -> 'a -> int
+val fixed_length : 'a Encoding.t -> int option
+val fixed_length_exn : 'a Encoding.t -> int

src/lib_data_encoding/data_encoding.ml

@@ -24,6 +24,7 @@ module Bson = Bson
 module Binary = struct
   include Binary
   include Binary_error
+  include Binary_length
   include Binary_reader
   include Binary_stream_reader
 end