abstracting headers and merkle of list construction

5 files changed, 25 insertions, 26 deletions

diff --git a/lib/kernel/Merkle.ml b/lib/kernel/Merkle.ml
index 4235914..266a560 100644
--- a/lib/kernel/Merkle.ml
+++ b/lib/kernel/Merkle.ml
@@ -29,6 +29,9 @@ module type TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> sig
   val insert :
     S.transaction -> K.t -> address -> node -> (node, Concepts.Condition.condition) result
 
+  val of_list :
+    S.transaction -> (K.t * address) list -> (node, Concepts.Condition.condition) result
+
   val remove : S.transaction -> K.t -> node -> (node, Concepts.Condition.condition) result
   val lookup : S.transaction -> K.t -> node -> (address option, Concepts.Condition.condition) result
 
@@ -323,6 +326,16 @@ functor
           let* _ = persist tx new_root in
           Ok new_root
 
+    let of_list tx bindings =
+      let open Utilities.Result in
+      with_batch tx (fun () ->
+          let* _ = empty_under tx in
+          List.fold_left
+            (fun node (key, value) ->
+              let* node = node in
+              insert tx key value node )
+            (Ok empty) bindings )
+
     let rec fold_left tx f acc =
       let open Utilities.Result in
       function
@@ -407,6 +420,7 @@ module type INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) (V : VA
   val empty_under : S.transaction -> (address, Concepts.Condition.condition) result
   val hash_of : node -> address
   val insert : S.transaction -> K.t -> V.t -> node -> (node, Concepts.Condition.condition) result
+  val of_list : S.transaction -> (K.t * V.t) list -> (node, Concepts.Condition.condition) result
   val remove : S.transaction -> K.t -> node -> (node, Concepts.Condition.condition) result
   val lookup : S.transaction -> K.t -> node -> (V.t option, Concepts.Condition.condition) result
   val mem : S.transaction -> K.t -> node -> (bool, Concepts.Condition.condition) result
@@ -458,6 +472,11 @@ functor
       let* addr = intern tx v in
       Tree.insert tx k addr node
 
+    let of_list tx bindings =
+      List.map (fun (k, v) -> intern tx v |> Result.map (fun addr -> k, addr)) bindings
+      |> Utilities.List.sequence
+      |> fmap (Tree.of_list tx)
+
     let remove = Tree.remove
 
     let lookup tx k node =
diff --git a/lib/kernel/Multigroup.ml b/lib/kernel/Multigroup.ml
index e6135c6..13ca7e0 100644
--- a/lib/kernel/Multigroup.ml
+++ b/lib/kernel/Multigroup.ml
@@ -116,15 +116,9 @@ module Make (S : Abstract.Storage.STORAGE) = struct
     |> Utilities.List.sequence
 
   let tree_of tx admissions =
-    let open Utilities.Result in
-    let* _ = T.empty_under tx in
-    T.with_batch tx (fun () ->
-        List.fold_left
-          (fun node (name, store) ->
-            let* node = node in
-            let* addr = store tx in
-            T.insert tx name addr node )
-          (Ok T.empty) admissions )
+    List.map (fun (name, store) -> store tx |> Result.map (fun addr -> name, addr)) admissions
+    |> Utilities.List.sequence
+    |> Utilities.Result.fmap (T.of_list tx)
 
   let admit_schema _ h =
     let open Utilities.Result in
diff --git a/lib/kernel/Namespace.ml b/lib/kernel/Namespace.ml
index c7c0767..80c446f 100644
--- a/lib/kernel/Namespace.ml
+++ b/lib/kernel/Namespace.ml
@@ -12,7 +12,7 @@ class namespace =
         Utilities.Atomic.mswap entries (fun e ->
             let existing = BatMap.find_opt key e in
             if existing = reference then begin
-              Option.map Protocols.Handle.release existing |> ignore;
+              Option.iter Protocols.Handle.release existing;
               match value with
               | Some v -> Ok (BatMap.add key (Protocols.Handle.move v) e)
               | None -> Ok (BatMap.remove key e)
diff --git a/lib/kernel/SubstantialRelation.ml b/lib/kernel/SubstantialRelation.ml
index 09aec90..9cb57f0 100644
--- a/lib/kernel/SubstantialRelation.ml
+++ b/lib/kernel/SubstantialRelation.ml
@@ -144,14 +144,8 @@ module Make (S : Abstract.Storage.STORAGE) = struct
   let store tx description tuples =
     let open Utilities.Result in
     let* schematics = store_schema tx description in
-    let* _ = TupleSet.empty_under tx in
     let* node =
-      TupleSet.with_batch tx (fun () ->
-          List.fold_left
-            (fun node tuple ->
-              let* node = node in
-              TupleSet.insert tx (Concepts.Tuple.hash tuple) tuple node )
-            (Ok TupleSet.empty) tuples )
+      TupleSet.of_list tx (List.map (fun tuple -> Concepts.Tuple.hash tuple, tuple) tuples)
     in
     let relation = {schematics; tuples= TupleSet.hash_of node} in
     let* _ = SI.store_blob tx (encode relation) in
diff --git a/lib/kernel/Tuple.ml b/lib/kernel/Tuple.ml
index 9dbbc17..41babe9 100644
--- a/lib/kernel/Tuple.ml
+++ b/lib/kernel/Tuple.ml
@@ -89,15 +89,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct
 
   let make tx ~type_ attributes =
     let open Utilities.Result in
-    let* node =
-      AttributeM.with_batch tx (fun () ->
-          BatMap.String.enum attributes
-          |> BatEnum.fold
-               (fun node (name, value) ->
-                 let* node = node in
-                 AttributeM.insert tx name value node )
-               (Ok AttributeM.empty) )
-    in
+    let* node = AttributeM.of_list tx (BatMap.String.bindings attributes) in
     Ok {type_; attributes= AttributeM.hash_of node}
 
   let attribute tx tuple name =