Associatives out of object properties

3 files changed, 37 insertions, 1 deletions

diff --git a/lib/kernel/Branch.ml b/lib/kernel/Branch.ml
index 54d5aaf..b8d331f 100644
--- a/lib/kernel/Branch.ml
+++ b/lib/kernel/Branch.ml
@@ -69,6 +69,13 @@ module Make (S : Abstract.Storage.STORAGE) = struct
 
     method protocols : Protocols.Handle.protocol list =
       Protocols.[ Addressable.make self;
+                  Prototype.Associative.(of_properties
+                    [ "multigroup", update_only (fun node' ->
+                                        let open Utilities.Result in
+                                        let* addressable = Handle.require Addressable.from node' in
+                                        let addr = Addressable.address addressable in
+                                        ignore addr;
+                                        failwith "TODO") ]);
                   Prototype.Directory.of_properties
                     [ "multigroup", Prototype.mixture_of node
                                       (fun make node ->
diff --git a/lib/kernel/Prototype.ml b/lib/kernel/Prototype.ml
index 8c12b40..65de68f 100644
--- a/lib/kernel/Prototype.ml
+++ b/lib/kernel/Prototype.ml
@@ -9,7 +9,32 @@ let mixture ps = Protocols.Handle.make @@
 let rec mixture_of value f =
   mixture (f (fun value' -> mixture_of value' f) value)
 
+module Error = struct
+  open Concepts.Condition
+
+  let invalid_property key = condition "invalid-property" "The specified key does not correspond to any property of the object"
+                               ("key" |=| Concepts.Value.String key)
+
+  let deletion_not_supported () = condition "deletion-not-supported" "Attempting to delete an object property"
+                                    empty
+end
+
 module Associative = struct
+  let of_properties props =
+    Protocols.Associative.make @@
+      object
+        val props = BatList.to_seq props |> BatMap.of_seq
+
+        method update key value =
+          match BatMap.find_opt key props with
+          | None -> Error (Error.invalid_property key)
+          | Some f -> f value
+      end
+
+  let update_only f = function
+    | None -> Error (Error.deletion_not_supported ())
+    | Some x -> f x
+
   module OfTree (S : Abstract.Storage.STORAGE) (K : Merkle.KEY with type t = string) = struct
     module Tree = Merkle.Make (S) (K)
     module SI = Storage.Make (S)
@@ -35,7 +60,7 @@ module Associative = struct
 end
 
 module Directory = struct
-  let of_properties (props) =
+  let of_properties props =
     Protocols.Directory.make @@
       object
         val props = BatList.to_seq props |> BatMap.of_seq
diff --git a/lib/kernel/Prototype.mli b/lib/kernel/Prototype.mli
index 2c7d067..db55445 100644
--- a/lib/kernel/Prototype.mli
+++ b/lib/kernel/Prototype.mli
@@ -11,6 +11,10 @@ module Directory : sig
 end
 
 module Associative : sig
+  val of_properties : (string * (Protocols.Handle.t option -> (Protocols.Handle.t, Concepts.Condition.condition) result)) list -> Protocols.Handle.protocol
+
+  val update_only : (Protocols.Handle.t -> (Protocols.Handle.t, Concepts.Condition.condition) result) -> (Protocols.Handle.t option -> (Protocols.Handle.t, Concepts.Condition.condition) result)
+
   module OfTree (S : Abstract.Storage.STORAGE) (K : Merkle.KEY with type t = string) : sig
     module Tree : module type of Merkle.Make (S) (K)
     val make : storage:S.connection -> constructor:(Tree.node -> (Protocols.Handle.t, Concepts.Condition.condition) result) -> node:Tree.node -> Protocols.Handle.protocol