Use finger trees in more places

5 files changed, 26 insertions, 16 deletions

diff --git a/lib/kernel/Branch.ml b/lib/kernel/Branch.ml
index 239afda..6f851ed 100644
--- a/lib/kernel/Branch.ml
+++ b/lib/kernel/Branch.ml
@@ -133,7 +133,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct
               object
                 method check =
                   let* named = Directory.children multigroups in
-                  Utilities.List.concat_map admits named
+                  Utilities.List.concat_mapm admits (BatFingerTree.to_list named) (* FIXME: use finger trees *)
               end;
             Prototype.Associative.(
               of_properties
diff --git a/lib/kernel/Merkle.ml b/lib/kernel/Merkle.ml
index c64a9a3..714f5ba 100644
--- a/lib/kernel/Merkle.ml
+++ b/lib/kernel/Merkle.ml
@@ -30,6 +30,7 @@ module type TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> sig
     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 of_finger_tree : S.transaction -> (K.t * address) BatFingerTree.t -> (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
 
@@ -332,6 +333,14 @@ functor
             (fun node (key, value) -> insert tx key value node)
             empty bindings )
 
+    let of_finger_tree tx bindings =
+      let open Utilities.Result in
+      with_batch tx (fun () ->
+          let* _ = empty_under tx in
+          Utilities.FingerTree.foldm_left
+            (fun node (key, value) -> insert tx key value node)
+            empty bindings )
+
     let rec fold_left tx f acc =
       let open Utilities.Result in
       function
diff --git a/lib/kernel/Multigroup.ml b/lib/kernel/Multigroup.ml
index 7aa1898..1b93e0c 100644
--- a/lib/kernel/Multigroup.ml
+++ b/lib/kernel/Multigroup.ml
@@ -108,18 +108,18 @@ module Make (S : Abstract.Storage.STORAGE) = struct
     let open Utilities.Result in
     let* listing = Protocols.Handle.require Protocols.Directory.from h in
     let* found = Protocols.Directory.find listing property in
-    let* children = Option.fold ~none:(Ok []) ~some:Protocols.Directory.children found in
-    List.map
+    let* children = Option.fold ~none:(Ok BatFingerTree.empty) ~some:Protocols.Directory.children found in
+    BatFingerTree.map
       (fun (name, child) ->
         Prototype.Associative.admission admit name child |> Result.map (fun p -> name, p) )
       children
-    |> Utilities.List.sequence
+    |> Utilities.FingerTree.sequence
 
   let tree_of tx admissions =
     let open Utilities.Result in
-    List.map (fun (name, store) -> store tx |> Result.map (fun addr -> name, addr)) admissions
-    |> Utilities.List.sequence
-    |>> T.of_list tx
+    BatFingerTree.map (fun (name, store) -> store tx |> Result.map (fun addr -> name, addr)) admissions
+    |> Utilities.FingerTree.sequence
+    |>> T.of_finger_tree tx
 
   let admit_schema _ h =
     let open Utilities.Result in
@@ -223,7 +223,8 @@ module Make (S : Abstract.Storage.STORAGE) = struct
       method check =
         let open Utilities.Result in
         let* named = Protocols.Directory.children (relations ?bind storage denial_tree) in
-        Utilities.List.concat_map (held ?bind) named
+        let named = BatFingerTree.to_list named in (* FIXME *)
+        Utilities.List.concat_mapm (held ?bind) named
 
       method protocols : Protocols.Handle.protocol list =
         let open Utilities.Result in
diff --git a/lib/kernel/Path.ml b/lib/kernel/Path.ml
index 4dfba36..512cfb0 100644
--- a/lib/kernel/Path.ml
+++ b/lib/kernel/Path.ml
@@ -102,7 +102,7 @@ let assoc_all handle changes =
     | Some (_, key, _) -> Error (Error.overlapping_change (prefix @ [key]))
     | None ->
         let* children =
-          Utilities.List.concat_map
+          Utilities.List.concat_mapm
             (fun (x, beneath) ->
               let* dir = Handle.require Directory.from node in
               let* found = Directory.find dir x in
@@ -150,7 +150,7 @@ let diff a b =
     let* left = names a in
     let* right = names b in
     List.sort_uniq String.compare (left @ right)
-    |> Utilities.List.concat_map (fun name ->
+    |> Utilities.List.concat_mapm (fun name ->
         let path = prefix @ [name] in
         let* x = find a name in
         let* y = find b name in
diff --git a/lib/kernel/Scope.ml b/lib/kernel/Scope.ml
index cd82b26..ba9c1e0 100644
--- a/lib/kernel/Scope.ml
+++ b/lib/kernel/Scope.ml
@@ -44,20 +44,20 @@ let attribute home relation text =
 (* every relation of a branch state, as multigroup:schema:relation *)
 let catalog_of branch =
   let open Utilities.Result in
-  let name prefix last = String.concat ":" (List.rev (last :: prefix)) in
+  let name prefix last = Utilities.FingerTree.join (BatFingerTree.reverse (BatFingerTree.cons prefix last)) ":" in
   let rec down prefix handle properties =
     let* level = Path.find handle Path.(List.hd properties @/ this) in
     match level, List.tl properties with
-    | None, _ -> Ok []
+    | None, _ -> Ok BatFingerTree.empty
     | Some level, [] ->
         let* listing = Protocols.Handle.require Protocols.Directory.from level in
         let* names = Protocols.Directory.list listing in
-        Ok (List.map (name prefix) (BatFingerTree.to_list names))
+        Ok (BatFingerTree.map (name prefix) names)
     | Some level, rest ->
         let* named = Protocols.Directory.children level in
-        Utilities.List.concat_map (fun (n, child) -> down (n :: prefix) child rest) named
+        Utilities.FingerTree.concat_mapm (fun (n, child) -> down (BatFingerTree.cons prefix n) child rest) named
   in
-  down [] branch ["multigroup"; "schema"; "relation"]
+  down BatFingerTree.empty branch ["multigroup"; "schema"; "relation"]
 
 let rec make branch home =
   Prototype.mixture
@@ -88,7 +88,7 @@ let rec make branch home =
             let* previous = Path.find branch Path.("previous" @/ this) in
             Ok (Option.map (fun p -> make p home) previous)
 
-          method catalog = catalog_of branch
+          method catalog = catalog_of branch |> Result.map BatFingerTree.to_list (* FIXME: use finger trees thoroughly *)
         end ]
 
 let heads = Path.("system" @/ "branch" @/ this)