aboutsummaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/Utilities.ml6
-rw-r--r--lib/Utilities.mli1
-rw-r--r--lib/kernel/Branch.ml2
-rw-r--r--lib/kernel/Merkle.ml9
-rw-r--r--lib/kernel/Multigroup.ml15
-rw-r--r--lib/kernel/Path.ml4
-rw-r--r--lib/kernel/Scope.ml12
-rw-r--r--lib/protocols/Directory.ml8
-rw-r--r--lib/protocols/Directory.mli2
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
generated by cgit v1.2.3 (git 2.25.1) at 2026-11-04 01:55:17 +0000