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
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_allowing_substitution =
S_allowing_substitution 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
let create_stable_witness raw_stable_witness =
Stable_witness.of_serializable raw_stable_witness create_exn raw
;;
let type_equal = Type_equal.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