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

type protocol = ..

module Error = struct
  open Concepts.Condition

  let unimplemented_protocol obj_name =
    condition "unimplemented-protocol"
      "A required protocol was not implemented by the specified object"
      ("object" |=| Concepts.Value.String obj_name)
end

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

type t = {valid: bool Atomic.t; refers_to: obj}
type 'a interface = {handle: t; interface: 'a}

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

let interface_of handle interface = {handle; interface}
let make o = {valid= Atomic.make 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 from {handle; _} = handle

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 protocols h = (object_of h)#protocols
let to_string h = let o = (object_of h) in "#<" ^ o#to_string ^ " " ^ (Concepts.Hash.to_hum_string o#hash) ^ ">"

let release ({valid; _} as handle) =
  let o = object_of handle in
  if Atomic.compare_and_set valid true false then
    o#release

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