6 files changed, 119 insertions, 0 deletions
diff --git a/lib/protocols/Directory.ml b/lib/protocols/Directory.ml
new file mode 100644
index 0000000..5b21668
--- /dev/null
+++ b/lib/protocols/Directory.ml
@@ -0,0 +1,16 @@
+class type implementation = object
+  method list : string list
+  method find : string -> Handle.t option
+end
+
+type Handle.protocol += Directory of implementation
+
+type t = implementation
+
+let make impl = Directory (impl :> implementation)
+
+let from handle = Handle.into handle (function Directory impl -> Some impl | _ -> None)
+
+let list i = Handle.invoke i (fun o -> o#list)
+
+let find i name = Handle.invoke i (fun o -> o#find name)
diff --git a/lib/protocols/Directory.mli b/lib/protocols/Directory.mli
new file mode 100644
index 0000000..5bf5277
--- /dev/null
+++ b/lib/protocols/Directory.mli
@@ -0,0 +1,13 @@
+type t
+
+class type implementation = object
+  method list : string list
+  method find : string -> Handle.t option
+end
+
+val make : #implementation -> Handle.protocol
+
+val from : Handle.t -> t Handle.interface option
+
+val list : t Handle.interface -> string list
+val find : t Handle.interface -> string -> Handle.t option
diff --git a/lib/protocols/Handle.ml b/lib/protocols/Handle.ml
new file mode 100644
index 0000000..9fd1f29
--- /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 :> 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 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..099f563
--- /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
diff --git a/lib/protocols/Registry.ml b/lib/protocols/Registry.ml
new file mode 100644
index 0000000..4c47001
--- /dev/null
+++ b/lib/protocols/Registry.ml
@@ -0,0 +1,16 @@
+class type implementation = object
+  method register : string -> Handle.t -> (unit, Concepts.Condition.condition) result
+  method unregister : string -> (unit, Concepts.Condition.condition) result
+end
+
+type Handle.protocol += Registry of implementation
+
+type t = implementation
+
+let make impl = Registry (impl :> implementation)
+
+let from handle = Handle.into handle (function Registry impl -> Some impl | _ -> None)
+
+let register i key value = Handle.invoke i (fun o -> o#register key value)
+
+let unregister i key = Handle.invoke i (fun o -> o#unregister key)
diff --git a/lib/protocols/Registry.mli b/lib/protocols/Registry.mli
new file mode 100644
index 0000000..175ebed
--- /dev/null
+++ b/lib/protocols/Registry.mli
@@ -0,0 +1,13 @@
+type t
+
+class type implementation = object
+  method register : string -> Handle.t -> (unit, Concepts.Condition.condition) result
+  method unregister : string -> (unit, Concepts.Condition.condition) result
+end
+
+val make : #implementation -> Handle.protocol
+
+val from : Handle.t -> t Handle.interface option
+
+val register : t Handle.interface -> string -> Handle.t -> (unit, Concepts.Condition.condition) result
+val unregister : t Handle.interface -> string -> (unit, Concepts.Condition.condition) result