Error monad: Better error for non-object error encodings
This commit is contained in:
parent
25bc6bfc96
commit
abd5bb22a8
@ -550,18 +550,29 @@ module Encoding = struct
|
|||||||
let obj10 f10 f9 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)
|
raw_merge_objs (obj2 f10 f9) (obj8 f8 f7 f6 f5 f4 f3 f2 f1)
|
||||||
|
|
||||||
|
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
|
||||||
|
| _ -> 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
|
||||||
|
| _ -> false
|
||||||
|
|
||||||
let merge_objs o1 o2 =
|
let merge_objs o1 o2 =
|
||||||
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
|
|
||||||
| _ -> false in
|
|
||||||
if is_obj o1 && is_obj o2 then
|
if is_obj o1 && is_obj o2 then
|
||||||
raw_merge_objs o1 o2
|
raw_merge_objs o1 o2
|
||||||
else
|
else
|
||||||
@ -592,15 +603,6 @@ module Encoding = struct
|
|||||||
raw_merge_tups (tup2 e10 e9) (tup8 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 =
|
let merge_tups t1 t2 =
|
||||||
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
|
|
||||||
| _ -> false in
|
|
||||||
if is_tup t1 && is_tup t2 then
|
if is_tup t1 && is_tup t2 then
|
||||||
raw_merge_tups t1 t2
|
raw_merge_tups t1 t2
|
||||||
else
|
else
|
||||||
|
@ -143,6 +143,12 @@ val result : 'a encoding -> 'b encoding -> ('a, 'b) result encoding
|
|||||||
val string_enum : (string * 'a) list -> 'a encoding
|
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.
|
(** Create encodings that produce data of a fixed length when binary encoded.
|
||||||
See the preamble for an explanation. *)
|
See the preamble for an explanation. *)
|
||||||
module Fixed : sig
|
module Fixed : sig
|
||||||
|
@ -60,6 +60,11 @@ module Make() = struct
|
|||||||
invalid_arg
|
invalid_arg
|
||||||
(Printf.sprintf
|
(Printf.sprintf
|
||||||
"register_error_kind: duplicate error name: %s" name) ;
|
"register_error_kind: duplicate error name: %s" name) ;
|
||||||
|
if not (Data_encoding.is_obj encoding)
|
||||||
|
then invalid_arg
|
||||||
|
(Printf.sprintf
|
||||||
|
"Specified encoding for \"%s\" is not an object, but error encodings must be objects."
|
||||||
|
name) ;
|
||||||
let encoding_case =
|
let encoding_case =
|
||||||
let open Data_encoding in
|
let open Data_encoding in
|
||||||
case
|
case
|
||||||
|
Loading…
Reference in New Issue
Block a user