lib/protocols/Handle.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

type protocol = ..

module Error = struct
  open Concepts.Condition

  let unimplemented_protocol () = condition "unimplemented-protocol" "A required protocol was not implemented by the specified object"
                                    empty
end

class type obj = object
  method reference : bool
  method release : unit
  method hash : Concepts.Hash.hash
  method protocols : protocol list
end

type t = { valid : bool ref; refers_to : obj }

type 'a interface = { handle : t; interface : 'a }

let object_of { valid; refers_to } =
  if !valid then
    refers_to
  else
    failwith "Attempt to dereference an invalid handle!"

let interface_of handle interface = { handle; interface }

let make o = { valid = ref true; refers_to = (o :> obj) }

let into handle f =
  List.find_map f (object_of handle)#protocols
  |> Option.map (interface_of handle)

let invoke { handle; interface } f =
  let _ = object_of handle in
  f interface

let copy handle =
  let o = object_of handle in
  if o#reference then
    Some (make o)
  else
    None

let equal h1 h2 =
  Concepts.Hash.hash_equals (object_of h1)#hash (object_of h2)#hash

let hash h = (object_of h)#hash

let release ({ valid; _ } as handle) =
  let o = object_of handle in
  valid := false;
  o#release

let require f h = Option.to_result ~none:(Error.unimplemented_protocol ()) (f h)