2 files changed, 61 insertions, 0 deletions
diff --git a/lib/protocols/Handle.ml b/lib/protocols/Handle.ml
new file mode 100644
index 0000000..1868737
--- /dev/null
+++ b/lib/protocols/Handle.ml
@@ -0,0 +1,41 @@
+type protocol = ..
+
+class type obj = object
+  method reference : bool
+  method release : unit
+  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 }
+
+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 release ({ valid; _ } as handle) =
+  let o = object_of handle in
+  valid := false;
+  o#release
diff --git a/lib/protocols/Handle.mli b/lib/protocols/Handle.mli
new file mode 100644
index 0000000..6fe175b
--- /dev/null
+++ b/lib/protocols/Handle.mli
@@ -0,0 +1,20 @@
+type t
+
+type 'a interface
+
+type protocol = ..
+
+class type obj = object
+  method reference : bool
+  method release : unit
+  method protocols : protocol list
+end
+
+val make : obj -> t
+
+val into : t -> (protocol -> 'a option) -> 'a interface option
+
+val invoke : 'a interface -> ('a -> 'b) -> 'b
+
+val copy : t -> t option
+val release : t -> unit