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
open! Import
open Std_internal
open Validated_intf
module type Raw = Raw
type ('raw, 'witness) t = 'raw
module type S = S with type ('a, 'b) validated := ('a, 'b) t
module type S_bin_io = S_bin_io with type ('a, 'b) validated := ('a, 'b) t
module type S_bin_io_compare_hash_sexp =
S_bin_io_compare_hash_sexp with type ('a, 'b) validated := ('a, 'b) t
let raw t = t
module Make (Raw : Raw) = struct
type witness
type t = Raw.t [@@deriving sexp_of]
let validation_failed t error =
Error.create
"validation failed"
(t, error, Raw.here)
[%sexp_of: Raw.t * Error.t * Source_code_position.t]
;;
let create_exn t =
match Validate.result (Raw.validate t) with
| Ok () -> t
| Error error -> Error.raise (validation_failed t error)
;;
let create t =
match Validate.result (Raw.validate t) with
| Ok () -> Ok t
| Error error -> Error (validation_failed t error)
;;
let t_of_sexp sexp = create_exn (Raw.t_of_sexp sexp)
let raw t = t
end
module Add_bin_io (Raw : sig
type t [@@deriving bin_io]
include Raw_bin_io with type t := t
end)
(Validated : S with type raw := Raw.t) =
struct
include
Binable.Of_binable_without_uuid [@alert "-legacy"]
(Raw)
(struct
type t = Raw.t
let of_binable raw =
if Raw.validate_binio_deserialization then Validated.create_exn raw else raw
;;
let to_binable = Fn.id
end)
end
module Add_compare (Raw : sig
type t [@@deriving compare]
include Raw with type t := t
end)
(_ : S with type raw := Raw.t) =
struct
let compare t1 t2 = [%compare: Raw.t] (raw t1) (raw t2)
end
module Add_hash (Raw : sig
type t [@@deriving hash]
include Raw with type t := t
end)
(Validated : S with type raw := Raw.t) =
struct
let hash_fold_t state t = Raw.hash_fold_t state (Validated.raw t)
let hash t = Raw.hash (Validated.raw t)
end
module Add_typerep (Raw : sig
type t [@@deriving typerep]
include Raw with type t := t
end)
(_ : S with type raw := Raw.t) =
struct
type t = Raw.t [@@deriving typerep]
end
module Make_binable (Raw : Raw_bin_io) = struct
module T0 = Make (Raw)
include T0
include Add_bin_io (Raw) (T0)
end
module Make_bin_io_compare_hash_sexp (Raw : sig
type t [@@deriving compare, hash]
include Raw_bin_io with type t := t
end) =
struct
module T = Make_binable (Raw)
include T
include Add_compare (Raw) (T)
include (
Add_hash (Raw) (T) :
sig
type t [@@deriving hash]
end
with type t := t)
end