Source file perms.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
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
open! Import
module Binable = Binable0

(* All the types as exposed in the mli are defined in this [Types] module.  The rest of
   this file is simply overriding all the bin_io, compare, and sexp functions to raise
   exceptions. *)
module Types = struct
  module Nobody = struct
    type t [@@deriving bin_io, compare, hash, sexp]

    let name = "Nobody"
  end

  module Me = struct
    type t [@@deriving bin_io, compare, hash, sexp]

    let name = "Me"
  end

  module Read = struct
    type t = [ `Read ] [@@deriving bin_io, compare, hash, sexp]

    let name = "Read"
  end

  module Write = struct
    type t = [ `Who_can_write of Me.t ] [@@deriving bin_io, compare, hash, sexp]

    let name = "Write"
  end

  module Immutable = struct
    type t =
      [ Read.t
      | `Who_can_write of Nobody.t
      ]
    [@@deriving bin_io, compare, hash, sexp]

    let name = "Immutable"
  end

  module Read_write = struct
    type t =
      [ Read.t
      | Write.t
      ]
    [@@deriving bin_io, compare, hash, sexp]

    let name = "Read_write"
  end

  module Upper_bound = struct
    type 'a t =
      [ Read.t
      | `Who_can_write of 'a
      ]
    [@@deriving bin_io, compare, hash, sexp]

    let name = "Upper_bound"
  end
end

let failwithf = Printf.failwithf

(* This is an explicit module type instead of just given inline as the return signature of
   [Only_used_as_phantom_type1] to avoid an unused value warning with bin_io values. *)
module type Sexpable_binable_comparable = sig
  type 'a t = 'a [@@deriving bin_io, compare, hash, sexp, sexp_grammar]
end

(* Override all bin_io, sexp, compare functions to raise exceptions *)
module Only_used_as_phantom_type1 (Name : sig
    val name : string
  end) : Sexpable_binable_comparable = struct
  type 'a t = 'a

  let sexp_of_t _ _ = failwithf "Unexpectedly called [%s.sexp_of_t]" Name.name ()
  let t_of_sexp _ _ = failwithf "Unexpectedly called [%s.t_of_sexp]" Name.name ()
  let compare _ _ _ = failwithf "Unexpectedly called [%s.compare]" Name.name ()
  let hash_fold_t _ _ _ = failwithf "Unexpectedly called [%s.hash_fold_t]" Name.name ()
  let t_sexp_grammar _ = Sexplib.Sexp_grammar.coerce Base.Nothing.t_sexp_grammar

  include
    Binable.Of_binable1_without_uuid [@alert "-legacy"]
      (struct
        type 'a t = 'a [@@deriving bin_io]
      end)
      (struct
        type nonrec 'a t = 'a t

        let to_binable _ =
          failwithf "Unexpectedly used %s bin_io serialization" Name.name ()
        ;;

        let of_binable _ =
          failwithf "Unexpectedly used %s bin_io deserialization" Name.name ()
        ;;
      end)
end

module Only_used_as_phantom_type0 (T : sig
    type t [@@deriving bin_io, compare, hash, sexp]

    val name : string
  end) : sig
  type t = T.t [@@deriving bin_io, compare, hash, sexp_poly]
end = struct
  module M = Only_used_as_phantom_type1 (T)

  type t = T.t M.t [@@deriving bin_io, compare, hash, sexp]

  let __t_of_sexp__ = t_of_sexp
end

module Stable = struct
  module V1 = struct
    module Nobody = Only_used_as_phantom_type0 (Types.Nobody)
    module Me = Only_used_as_phantom_type0 (Types.Me)
    module Read = Only_used_as_phantom_type0 (Types.Read)
    module Write = Only_used_as_phantom_type0 (Types.Write)
    module Read_write = Only_used_as_phantom_type0 (Types.Read_write)
    module Immutable = Only_used_as_phantom_type0 (Types.Immutable)

    type nobody = Nobody.t [@@deriving bin_io, compare, hash, sexp]
    type me = Me.t [@@deriving bin_io, compare, hash, sexp]

    module Upper_bound = struct
      module M = Only_used_as_phantom_type1 (Types.Upper_bound)

      type 'a t = 'a Types.Upper_bound.t M.t [@@deriving bin_io, compare, hash, sexp]

      let __t_of_sexp__ = t_of_sexp
    end
  end

  module Export = struct
    type read = V1.Read.t [@@deriving bin_io, compare, hash, sexp]
    type write = V1.Write.t [@@deriving compare, hash, sexp]
    type immutable = V1.Immutable.t [@@deriving bin_io, compare, hash, sexp]
    type read_write = V1.Read_write.t [@@deriving bin_io, compare, hash, sexp]
    type 'a perms = 'a V1.Upper_bound.t [@@deriving bin_io, compare, hash, sexp]
  end
end

include Stable.V1
module Export = Stable.Export