Data_encoding: move internal function internally
This commit is contained in:
parent
34d4e9ec5d
commit
194d3f9120
@ -7,6 +7,15 @@
|
|||||||
(* *)
|
(* *)
|
||||||
(**************************************************************************)
|
(**************************************************************************)
|
||||||
|
|
||||||
|
let apply_and_get_first_some ?(error=Encoding.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
|
||||||
|
|
||||||
type 'l writer = {
|
type 'l writer = {
|
||||||
write: 'a. 'a Encoding.t -> 'a -> MBytes.t -> int -> int ;
|
write: 'a. 'a Encoding.t -> 'a -> MBytes.t -> int -> int ;
|
||||||
}
|
}
|
||||||
@ -55,7 +64,7 @@ let rec length : type x. x Encoding.t -> x -> int = fun e ->
|
|||||||
let case_length (Case { encoding = e ; proj }) =
|
let case_length (Case { encoding = e ; proj }) =
|
||||||
let length v = tag_size + length e v in
|
let length v = tag_size + length e v in
|
||||||
fun v -> Option.map ~f:length (proj v) in
|
fun v -> Option.map ~f:length (proj v) in
|
||||||
apply (List.map case_length cases)
|
apply_and_get_first_some (List.map case_length cases)
|
||||||
| Mu (`Dynamic, _name, self) ->
|
| Mu (`Dynamic, _name, self) ->
|
||||||
fun v -> length (self e) v
|
fun v -> length (self e) v
|
||||||
| Obj (Opt (`Dynamic, _, e)) ->
|
| Obj (Opt (`Dynamic, _, e)) ->
|
||||||
@ -102,7 +111,7 @@ let rec length : type x. x Encoding.t -> x -> int = fun e ->
|
|||||||
| Some v -> Some (length v)) :: acc)
|
| Some v -> Some (length v)) :: acc)
|
||||||
tl in
|
tl in
|
||||||
let cases, json_only = case_lengths false [] cases in
|
let cases, json_only = case_lengths false [] cases in
|
||||||
apply
|
apply_and_get_first_some
|
||||||
~error:(if json_only
|
~error:(if json_only
|
||||||
then Failure "No case matched, but JSON only cases were present in union"
|
then Failure "No case matched, but JSON only cases were present in union"
|
||||||
else No_case_matched)
|
else No_case_matched)
|
||||||
@ -232,7 +241,7 @@ module Writer = struct
|
|||||||
match proj v with
|
match proj v with
|
||||||
| None -> None
|
| None -> None
|
||||||
| Some v -> Some (write v)) in
|
| Some v -> Some (write v)) in
|
||||||
apply (TzList.filter_map writes_case cases)
|
apply_and_get_first_some (TzList.filter_map writes_case cases)
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
|
@ -17,16 +17,6 @@ exception Int_out_of_range of int * int * int
|
|||||||
exception Float_out_of_range of float * float * float
|
exception Float_out_of_range of float * float * float
|
||||||
exception Parse_error of string
|
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 Kind = struct
|
module Kind = struct
|
||||||
|
|
||||||
|
@ -50,8 +50,6 @@
|
|||||||
* predicates, etc.) *)
|
* predicates, etc.) *)
|
||||||
(* TODO: move the doc into the packing module *)
|
(* TODO: move the doc into the packing module *)
|
||||||
|
|
||||||
val apply: ?error:exn -> ('a -> 'b option) list -> 'a -> 'b
|
|
||||||
|
|
||||||
module Kind: sig
|
module Kind: sig
|
||||||
|
|
||||||
type t = [ `Fixed of int | `Dynamic | `Variable ]
|
type t = [ `Fixed of int | `Dynamic | `Variable ]
|
||||||
|
Loading…
Reference in New Issue
Block a user