1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
open Types
open Error
open Result
open Open
open Internal
module Make(A : Min) = struct
include A
exception Exception of target Error.t
type 'a encoder = ('a, target) Encoder.t
type 'a decoder = ('a, target) Decoder.t
type 'a decoder_exn = ('a, target) Decoder.t_exn
let decoder_of_deconstr f = fun ?(trace=([] : target Error.trace)) t ->
try Ok (f t) with exn -> Error (`Exception exn, t, trace)
let decoder_exn_of_deconstr f = fun ?(trace=([] : target Error.trace)) t ->
try f t with exn -> raise (Exception (`Exception exn, t, trace))
module DeconstrDecoder = struct
let tuple ?trace = decoder_of_deconstr Deconstr.tuple ?trace
let variant tyname ?trace = decoder_of_deconstr (Deconstr.variant tyname) ?trace
let poly_variant tyname ?trace = decoder_of_deconstr (Deconstr.poly_variant tyname) ?trace
let record tyname ?trace = decoder_of_deconstr (Deconstr.record tyname) ?trace
let object_ tyname ?trace = decoder_of_deconstr (Deconstr.object_ tyname) ?trace
let tuple_exn ?trace = decoder_exn_of_deconstr Deconstr.tuple ?trace
let variant_exn tyname ?trace = decoder_exn_of_deconstr (Deconstr.variant tyname) ?trace
let poly_variant_exn tyname ?trace = decoder_exn_of_deconstr (Deconstr.poly_variant tyname) ?trace
let record_exn tyname ?trace = decoder_exn_of_deconstr (Deconstr.record tyname) ?trace
let object_exn tyname ?trace = decoder_exn_of_deconstr (Deconstr.object_ tyname) ?trace
end
let exn f ?trace v = match f ?trace v with
| Ok v -> v
| Error e -> raise (Exception e)
let throw e = raise (Exception e)
let catch f v = try Ok (f v) with Exception e -> Error e
let result f ?trace t =
try Ok (f ?trace t) with
| Exception e -> Error e
| exn -> Error (`Exception exn, t, ~?trace)
let from_Ok = function
| Ok v -> v
| Error e -> raise (Exception e)
let format_error ppf (desc,_,_) = Error.format_desc ppf desc
let format_full_error = Error.format A.format
let format_with encoder ppf t = format ppf (encoder t)
module Helper = struct
(** {6 Useful tool functions for writing encoders+decoders of primitive types } *)
let integer_of_float min max conv n =
if floor n <> n then Error "not an integer"
else if min <= n && n <= max then Ok (conv n)
else Error "overflow"
let list_of (type target) gets (d : (_,target) Decoder.t) ?(trace=[]) v = match gets v with
| None ->
primitive_decoding_failure
"Meta_conv.Internal.generic_list_of: listable expected"
~trace
v
| Some xs ->
let trace = `Node v::trace in
let module E = LocalException(struct type t = target end) in
E.catch begin fun () ->
list_mapi (fun pos x -> E.exn (d ~trace:(`Pos pos :: trace)) x) xs
end ()
let array_of gets d ?trace v =
fmap Array.of_list (list_of gets d ?trace v)
let option_of f ?trace v =
match extract v with
| Some None -> Ok None
| Some (Some v) -> f ?trace v >>= fun x -> Ok (Some x)
| None ->
primitive_decoding_failure
"Meta_conv.Internal.option_of: option expected"
?trace v
let ref_of f ?trace v =
match extract v with
| Some v -> f ?trace v >>= fun x -> Ok { contents= x }
| None ->
primitive_decoding_failure
"Meta_conv.Internal.ref_of: option expected"
?trace v
let lazy_t_of (errorf : 'target Error.t -> 'exn) f ?trace:_ v =
Ok (lazy (
match f ?trace:None v with
| Ok v -> v
| Error e -> errorf e
))
let of_mc_lazy_t e = fun v ->
match Lazy.force v with
| Ok a -> e a
| Error (_, a, _) -> a
let mc_lazy_t_of f ?trace:_ v =
Ok (lazy (f ?trace:None v))
let mc_fields_of get_fields f ?(trace=[]) target =
let open Result in
match get_fields target with
| None -> primitive_decoding_failure "mc_fields expected" ~trace target
| Some fields ->
let trace = `Node target :: trace in
map (fun (name, target) -> f ?trace:(Some (`Field name :: trace)) target >>= fun host -> Ok (name, host)) fields
let of_deconstr f = fun ?(trace=[]) v ->
try Ok (f v) with
| Failure mes -> Error (`Primitive_decoding_failure mes, v, trace)
(** Hashtbl coders via list *)
let of_hashtbl of_list of_a of_b tbl =
of_list
(fun x -> x)
(Hashtbl.fold (fun k v st -> Constr.tuple [of_a k; of_b v]::st) tbl [])
let hashtbl_of list_of a_of b_of = fun ?trace v ->
let ab_of ?(trace=[]) v =
DeconstrDecoder.tuple ~trace v >>= function
| [a; b] ->
a_of ?trace:(Some (`Pos 0 :: `Node v :: trace)) a >>= fun a ->
b_of ?trace:(Some (`Pos 0 :: `Node v :: trace)) b >>= fun b ->
Ok (a,b)
| xs ->
Error (`Wrong_arity (2, List.length xs, None), v, trace)
in
list_of ab_of ?trace v >>= fun abs ->
let tbl = Hashtbl.create 101 in
List.iter (fun (k,v) -> Hashtbl.add tbl k v) abs;
Ok tbl
let of_result embed_ok embed_error of_ok of_error = function
| Ok e -> embed_ok @@ of_ok e
| Error e -> embed_error @@ of_error e
let result_of divider ok_of error_of ?trace v =
divider ?trace v >>= function
| (Ok v) -> ok_of ?trace v >>= fun x -> Ok (Ok x)
| (Error v) -> error_of ?trace v >>= fun x -> Ok (Error x)
end
end