Lifecycles and namespaces

6 files changed, 107 insertions, 0 deletions

diff --git a/lib/Utilities.ml b/lib/Utilities.ml
index a96d16f..52483b3 100644
--- a/lib/Utilities.ml
+++ b/lib/Utilities.ml
@@ -17,6 +17,11 @@ module Result = struct
                       (Ok [])
 end
 
+module Option = struct
+  let ( let* ) = Option.bind
+  let fmap f m = Option.bind m f
+end
+
 module Atomic = struct
   let rec swap atom f =
     let v = Atomic.get atom in
diff --git a/lib/Utilities.mli b/lib/Utilities.mli
index f9c0c29..9661796 100644
--- a/lib/Utilities.mli
+++ b/lib/Utilities.mli
@@ -10,6 +10,11 @@ module Result : sig
   val sequence : ('a, 'b) result list -> ('a list, 'b) result
 end
 
+module Option : sig
+  val ( let* ) : 'a option -> ('a -> 'b option) -> 'b option
+  val fmap : ('a -> 'b option) -> 'a option -> 'b option
+end
+
 module Atomic : sig
   val swap : 'a Atomic.t -> ('a -> 'a) -> 'a Atomic.t
   (* This is silly *)
diff --git a/lib/kernel/Lifecycle.ml b/lib/kernel/Lifecycle.ml
new file mode 100644
index 0000000..ff67ecf
--- /dev/null
+++ b/lib/kernel/Lifecycle.ml
@@ -0,0 +1,29 @@
+class type lifecycle = object
+  method reference : bool
+  method release : unit
+end
+
+class type virtual controlled_lifecycle = object
+  inherit lifecycle
+  method virtual destroy : unit
+end
+
+class null = object
+  method reference = true
+  method release = ()
+end
+
+class virtual counted = object (self)
+  val references = Atomic.make 1
+
+  method virtual destroy : unit
+
+  method reference =
+    Atomic.incr references;
+    true
+
+  method release =
+    Atomic.decr references;
+    if Atomic.get references <= 0 then
+      self#destroy
+end
diff --git a/lib/kernel/Lifecycle.mli b/lib/kernel/Lifecycle.mli
new file mode 100644
index 0000000..f110768
--- /dev/null
+++ b/lib/kernel/Lifecycle.mli
@@ -0,0 +1,12 @@
+class type lifecycle = object
+  method reference : bool
+  method release : unit
+end
+
+class type virtual controlled_lifecycle = object
+  inherit lifecycle
+  method virtual destroy : unit
+end
+
+class null : lifecycle
+class virtual counted : controlled_lifecycle
diff --git a/lib/kernel/Namespace.ml b/lib/kernel/Namespace.ml
new file mode 100644
index 0000000..7c9cd2b
--- /dev/null
+++ b/lib/kernel/Namespace.ml
@@ -0,0 +1,49 @@
+module Errors = struct
+  include Concepts.Condition
+
+  let key_already_exists key =
+    condition "key-already-exists" "The specified key already exists in the namespace"
+      ("key" |=| Concepts.Value.String key)
+
+  let no_such_key key =
+    condition "no-such-key" "The specified key does not exist in the namespace"
+      ("key" |=| Concepts.Value.String key)
+end
+
+class namespace = object (self)
+  inherit Lifecycle.null
+
+  val entries : (string, Protocols.Handle.t) BatMap.t Atomic.t =
+    Atomic.make BatMap.empty
+
+  method protocols = Protocols.[Directory.make self; Registry.make self]
+
+  method register key value =
+    Utilities.Atomic.mswap entries
+      (fun e ->
+        match BatMap.find_opt key e with
+        | None -> Ok (BatMap.add key value e)
+        | Some _ -> Error (Errors.key_already_exists key))
+    |> Result.map ignore
+
+  method unregister key =
+    Utilities.Atomic.mswap entries
+      (fun e ->
+        try
+          Ok (BatMap.remove_exn key e)
+        with Not_found ->
+          Error (Errors.no_such_key key))
+    |> Result.map ignore
+
+  method list =
+    Atomic.get entries
+    |> BatMap.keys
+    |> BatList.of_enum
+
+  method find key =
+    Atomic.get entries
+    |> BatMap.find_opt key
+    |> Utilities.Option.fmap Protocols.Handle.copy
+end
+
+let make () = new namespace
diff --git a/lib/kernel/Namespace.mli b/lib/kernel/Namespace.mli
new file mode 100644
index 0000000..3ed64a3
--- /dev/null
+++ b/lib/kernel/Namespace.mli
@@ -0,0 +1,7 @@
+class namespace : object
+  inherit Protocols.Handle.obj
+  inherit Protocols.Directory.implementation
+  inherit Protocols.Registry.implementation
+end
+
+val make : unit -> namespace