package core

  1. Overview
  2. Docs
package core
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file validated.ml

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