Associative collections on top of prolly trees

7 files changed, 77 insertions, 37 deletions

diff --git a/lib/backend/storage/LMDB.ml b/lib/backend/storage/LMDB.ml
index 85a9cf9..be23128 100644
--- a/lib/backend/storage/LMDB.ml
+++ b/lib/backend/storage/LMDB.ml
@@ -1,10 +1,3 @@
-(* @uses Configuration -- reads config term to connect *)
-(* @uses Hash -- hash keys for get/put *)
-(* @uses Representation -- blob encode/decode *)
-(* @needs Condition *)
-(* @needs Value *)
-(* @needs Storage *)
-
 module C = struct
   open Ctypes
   open PosixTypes
diff --git a/lib/kernel/Branch.ml b/lib/kernel/Branch.ml
index 3832a07..54d5aaf 100644
--- a/lib/kernel/Branch.ml
+++ b/lib/kernel/Branch.ml
@@ -11,6 +11,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct
   module M = Multigroup.Make (S)
   module MultigroupM = Merkle.Interface (S) (Merkle.StringKey) (M)
   module MMDirectory = Prototype.Directory.OfTree (S) (Merkle.StringKey) (M)
+  module MMAssociative = Prototype.Associative.OfTree (S) (Merkle.StringKey)
 
   module Error = struct
     open Concepts.Condition
@@ -69,10 +70,14 @@ module Make (S : Abstract.Storage.STORAGE) = struct
     method protocols : Protocols.Handle.protocol list =
       Protocols.[ Addressable.make self;
                   Prototype.Directory.of_properties
-                    [ "multigroup", Prototype.mixture
-                                      [ MMDirectory.make
-                                          ~storage ~node
-                                          ~constructor:(M.wrap storage) ] ] ]
+                    [ "multigroup", Prototype.mixture_of node
+                                      (fun make node ->
+                                        [ MMDirectory.make
+                                            ~storage ~node
+                                            ~constructor:(M.wrap storage);
+	                                      MMAssociative.make
+                                            ~storage ~node:(MultigroupM.into node)
+                                            ~constructor:(fun node' -> MultigroupM.from node' |> make |> Result.ok) ]) ] ]
 
     method hash =
       Representation.to_blob branch
diff --git a/lib/kernel/Merkle.ml b/lib/kernel/Merkle.ml
index 3616c24..fc076ac 100644
--- a/lib/kernel/Merkle.ml
+++ b/lib/kernel/Merkle.ml
@@ -345,12 +345,16 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct
 end
 
 module type INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) (V : VALUE) -> sig
+  module Tree : module type of Make (S) (K)
+
   type address = Concepts.Hash.hash
   type node
 
   val with_batch: S.transaction -> (unit -> (node, Concepts.Condition.condition) result) -> (node, Concepts.Condition.condition) result
 
   val find : S.transaction -> address -> (node option, Concepts.Condition.condition) result
+  val from : Tree.node -> node
+  val into : node -> Tree.node
 
   val empty : node
   val empty_under : S.transaction -> (address, Concepts.Condition.condition) result
@@ -368,11 +372,11 @@ module type INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) (V : VA
 end
 
 module Interface : INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) (V : VALUE) -> struct
-  module T = Make (S) (K)
+  module Tree = Make (S) (K)
   module SI = Storage.Make (S)
 
-  type address = T.address
-  type node = T.node
+  type address = Tree.address
+  type node = Tree.node
 
   open Utilities.Result
 
@@ -384,28 +388,30 @@ module Interface : INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY)
 
   let retrieve tx addr = SI.get_req tx (S.Hash addr) |> fmap V.decode
 
-  let find = T.find
-  let empty = T.empty
-  let empty_under = T.empty_under
-  let hash_of = T.hash_of
-  let with_batch = T.with_batch
+  let find = Tree.find
+  let from x = x
+  let into x = x
+  let empty = Tree.empty
+  let empty_under = Tree.empty_under
+  let hash_of = Tree.hash_of
+  let with_batch = Tree.with_batch
 
   let insert tx k v node =
     let* addr = intern tx v in
-    T.insert tx k addr node
+    Tree.insert tx k addr node
 
-  let remove = T.remove
+  let remove = Tree.remove
 
   let lookup tx k node =
-    let* addr = T.lookup tx k node in
+    let* addr = Tree.lookup tx k node in
     match addr with
     | None -> Ok None
     | Some addr -> retrieve tx addr |> Result.map Option.some
 
-  let mem tx k node = T.lookup tx k node |> Result.map Option.is_some
+  let mem tx k node = Tree.lookup tx k node |> Result.map Option.is_some
 
   let fold_left tx f acc node =
-    T.fold_left tx
+    Tree.fold_left tx
       (fun acc k addr ->
         let* acc = acc in
         let* v = retrieve tx addr in
@@ -418,7 +424,7 @@ module Interface : INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY)
       (fun _ k v -> f k v |> ignore)
       () node
 
-  let keys = T.keys
+  let keys = Tree.keys
 end
 
 module StringKey : KEY with type t = string = struct
diff --git a/lib/kernel/Prototype.ml b/lib/kernel/Prototype.ml
index 9c1dcd2..8c12b40 100644
--- a/lib/kernel/Prototype.ml
+++ b/lib/kernel/Prototype.ml
@@ -6,6 +6,34 @@ let mixture ps = Protocols.Handle.make @@
                      method protocols = ps
                    end
 
+let rec mixture_of value f =
+  mixture (f (fun value' -> mixture_of value' f) value)
+
+module Associative = struct
+  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)
+
+    let make ~storage ~constructor ~node =
+      Protocols.Associative.make @@
+        object
+          method update key value =
+            (* TODO: read-only transactions *)
+            SI.with_transaction storage (fun tx ->
+                let open Utilities.Result in
+                let open Protocols in
+                let* node' = match value with
+                  | None -> Tree.remove tx key node
+                  | Some h ->
+                     let* addressable = Handle.require Addressable.from h in
+                     let addr = Addressable.address addressable in
+                     Tree.insert tx key addr node
+                in
+                constructor node')
+        end
+  end
+end
+
 module Directory = struct
   let of_properties (props) =
     Protocols.Directory.make @@
@@ -17,14 +45,14 @@ module Directory = struct
       end
 
   module OfTree (S : Abstract.Storage.STORAGE) (K : Merkle.KEY with type t = string) (V : Merkle.VALUE) = struct
-    module Interface = Merkle.Interface (S) (K) (V)
+    module Tree = Merkle.Interface (S) (K) (V)
     module SI = Storage.Make (S)
 
     let make ~storage ~constructor ~node =
       Protocols.Directory.make @@
         object
-          method list = SI.with_transaction storage (Fun.flip Interface.keys node)
-          method find k = SI.with_transaction storage (fun tx -> Interface.lookup tx k node)
+          method list = SI.with_transaction storage (Fun.flip Tree.keys node)
+          method find k = SI.with_transaction storage (fun tx -> Tree.lookup tx k node)
                           |> Utilities.Result.fmap (function
                                  | None -> Ok None
                                  | Some x -> constructor x |> Result.map (Option.some))
diff --git a/lib/kernel/Prototype.mli b/lib/kernel/Prototype.mli
index c1e93df..2c7d067 100644
--- a/lib/kernel/Prototype.mli
+++ b/lib/kernel/Prototype.mli
@@ -1,10 +1,18 @@
+val mixture_of : 'a -> (('a -> Protocols.Handle.t) -> 'a -> Protocols.Handle.protocol list) -> Protocols.Handle.t
 val mixture : Protocols.Handle.protocol list -> Protocols.Handle.t
 
 module Directory : sig
   val of_properties : (string * Protocols.Handle.t) list -> Protocols.Handle.protocol
 
   module OfTree (S : Abstract.Storage.STORAGE) (K : Merkle.KEY with type t = string) (V : Merkle.VALUE) : sig
-    module Interface : module type of Merkle.Interface (S) (K) (V)
-    val make : storage:S.connection -> constructor:(V.t -> (Protocols.Handle.t, Concepts.Condition.condition) result) -> node:Interface.node -> Protocols.Handle.protocol
+    module Tree : module type of Merkle.Interface (S) (K) (V)
+    val make : storage:S.connection -> constructor:(V.t -> (Protocols.Handle.t, Concepts.Condition.condition) result) -> node:Tree.node -> Protocols.Handle.protocol
+  end
+end
+
+module Associative : sig
+  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
   end
 end
diff --git a/lib/protocols/Associative.ml b/lib/protocols/Associative.ml
index aa691d0..66de5ed 100644
--- a/lib/protocols/Associative.ml
+++ b/lib/protocols/Associative.ml
@@ -1,5 +1,5 @@
 class type implementation = object
-  method update : string -> Handle.t option -> Handle.t option -> (Handle.t, Concepts.Condition.condition) result
+  method update : string -> Handle.t option -> (Handle.t, Concepts.Condition.condition) result
 end
 
 type Handle.protocol += Associative of implementation
@@ -10,7 +10,7 @@ let make impl = Associative (impl :> implementation)
 
 let from handle = Handle.into handle (function Associative impl -> Some impl | _ -> None)
 
-let update i key reference value = Handle.invoke i (fun o ->
-                                       let open Utilities.Result in
-                                       let* h = o#update key reference value in
-                                       Handle.require from h)
+let update i key value = Handle.invoke i (fun o ->
+                             let open Utilities.Result in
+                             let* h = o#update key value in
+                             Handle.require from h)
diff --git a/lib/protocols/Associative.mli b/lib/protocols/Associative.mli
index 6aecca3..066cfe4 100644
--- a/lib/protocols/Associative.mli
+++ b/lib/protocols/Associative.mli
@@ -1,11 +1,11 @@
 type t
 
 class type implementation = object
-  method update : string -> Handle.t option -> Handle.t option -> (Handle.t, Concepts.Condition.condition) result
+  method update : string -> Handle.t option -> (Handle.t, Concepts.Condition.condition) result
 end
 
 val make : #implementation -> Handle.protocol
 
 val from : Handle.t -> t Handle.interface option
 
-val update : t Handle.interface -> string -> Handle.t option -> Handle.t option -> (t Handle.interface, Concepts.Condition.condition) result
+val update : t Handle.interface -> string -> Handle.t option -> (t Handle.interface, Concepts.Condition.condition) result