From 8c2f0db7337328570af57461a3d95203537ac185 Mon Sep 17 00:00:00 2001 From: Estevan Castilho Date: Sat, 24 Oct 2026 03:35:20 +0000 Subject: Use finger trees in more places --- lib/kernel/Branch.ml | 2 +- lib/kernel/Merkle.ml | 9 +++++++++ lib/kernel/Multigroup.ml | 15 ++++++++------- lib/kernel/Path.ml | 4 ++-- lib/kernel/Scope.ml | 12 ++++++------ 5 files changed, 26 insertions(+), 16 deletions(-) (limited to 'lib/kernel') 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) -- cgit v1.2.3