aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/Utilities.ml5
-rw-r--r--lib/Utilities.mli5
-rw-r--r--lib/kernel/Lifecycle.ml29
-rw-r--r--lib/kernel/Lifecycle.mli12
-rw-r--r--lib/kernel/Namespace.ml49
-rw-r--r--lib/kernel/Namespace.mli7
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