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/Utilities.ml | 6 ++---- lib/Utilities.mli | 1 + 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 ++++++------ lib/protocols/Directory.ml | 8 ++++---- lib/protocols/Directory.mli | 2 +- 9 files changed, 34 insertions(+), 25 deletions(-) diff --git a/lib/Utilities.ml b/lib/Utilities.ml index 6f27b30..0472038 100644 --- a/lib/Utilities.ml +++ b/lib/Utilities.ml @@ -93,11 +93,9 @@ module FingerTree = struct match f elem with None -> acc | Some result -> BatFingerTree.snoc acc result) BatFingerTree.empty - let concat_mapm f xs = BatFingerTree.map f xs |> sequence |> Stdlib.Result.map BatFingerTree.append - - let concat_map f = - BatFingerTree.fold_left (fun acc elem -> BatFingerTree.append acc @@ f elem) BatFingerTree.empty + let concat xss = BatFingerTree.fold_left BatFingerTree.append BatFingerTree.empty xss + let concat_mapm f xs = BatFingerTree.map f xs |> sequence |> Stdlib.Result.map concat end module Atomic = struct diff --git a/lib/Utilities.mli b/lib/Utilities.mli index 3f0787f..e748693 100644 --- a/lib/Utilities.mli +++ b/lib/Utilities.mli @@ -36,6 +36,7 @@ module FingerTree : sig val foldm_left : ('a -> 'b -> ('a, 'e) result) -> 'a -> 'b BatFingerTree.t -> ('a, 'e) result val join : string BatFingerTree.t -> string -> string val filter_map : ('a -> 'b option) -> 'a BatFingerTree.t -> 'b BatFingerTree.t + val concat : 'a BatFingerTree.t BatFingerTree.t -> 'a BatFingerTree.t val concat_mapm : ('a -> ('b BatFingerTree.t, 'e) result) -> 'a BatFingerTree.t -> ('b BatFingerTree.t, 'e) result end 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) diff --git a/lib/protocols/Directory.ml b/lib/protocols/Directory.ml index b8caca0..fd45949 100644 --- a/lib/protocols/Directory.ml +++ b/lib/protocols/Directory.ml @@ -15,9 +15,9 @@ let children directory = let open Utilities.Result in let* listing = Handle.require from directory in let* names = list listing in - BatFingerTree.to_list names - |> List.map (fun name -> + names + |> BatFingerTree.map (fun name -> let* found = find listing name in Ok (Option.map (fun child -> name, child) found) ) - |> Utilities.List.sequence - |> Result.map (List.filter_map Fun.id) + |> Utilities.FingerTree.sequence + |> Result.map (Utilities.FingerTree.filter_map Fun.id) diff --git a/lib/protocols/Directory.mli b/lib/protocols/Directory.mli index 77cb27a..332b1b6 100644 --- a/lib/protocols/Directory.mli +++ b/lib/protocols/Directory.mli @@ -9,4 +9,4 @@ val make : #implementation -> Handle.protocol val from : Handle.t -> t Handle.interface option val list : t Handle.interface -> (string BatFingerTree.t, Concepts.Condition.condition) result val find : t Handle.interface -> string -> (Handle.t option, Concepts.Condition.condition) result -val children : Handle.t -> ((string * Handle.t) list, Concepts.Condition.condition) result +val children : Handle.t -> ((string * Handle.t) BatFingerTree.t, Concepts.Condition.condition) result -- cgit v1.2.3