Error monad: Better error for non-object error encodings

This commit is contained in:
Milo Davis 2017-12-04 12:10:20 +01:00 committed by Benjamin Canou
parent 25bc6bfc96
commit abd5bb22a8
3 changed files with 33 additions and 20 deletions

View File

@ -550,7 +550,6 @@ 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 merge_objs o1 o2 =
let rec is_obj : type a. a t -> bool = fun e -> let rec is_obj : type a. a t -> bool = fun e ->
match e.encoding with match e.encoding with
| Obj _ -> true | Obj _ -> true
@ -561,7 +560,19 @@ module Encoding = struct
List.for_all (fun (Case { encoding = e }) -> is_obj e) cases List.for_all (fun (Case { encoding = e }) -> is_obj e) cases
| Empty -> true | Empty -> true
| Ignore -> true | Ignore -> true
| _ -> false in | _ -> 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 =
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

View File

@ -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

View File

@ -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