diff options
| -rw-r--r-- | lib/Utilities.ml | 11 | ||||
| -rw-r--r-- | lib/Utilities.mli | 2 | ||||
| -rw-r--r-- | lib/evaluators/FOL.ml | 5 | ||||
| -rw-r--r-- | lib/kernel/Initialization.ml | 10 | ||||
| -rw-r--r-- | lib/kernel/Merkle.ml | 17 | ||||
| -rw-r--r-- | lib/kernel/Path.ml | 5 |
6 files changed, 24 insertions, 26 deletions
diff --git a/lib/Utilities.ml b/lib/Utilities.ml index c16be2e..b7fe364 100644 --- a/lib/Utilities.ml +++ b/lib/Utilities.ml @@ -21,6 +21,7 @@ module type SEQUENCE = sig val empty : 'a t val cons : 'a -> 'a t -> 'a t val fold : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val fold_left : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b end module Generic (S : SEQUENCE) = struct @@ -32,6 +33,14 @@ module Generic (S : SEQUENCE) = struct let* m = m in Ok (S.cons m acc) ) ms (Ok S.empty) + + let fold_left f init ms = + let open Result in + S.fold_left + (fun acc m -> + let* acc = acc in + f acc m ) + (Ok init) ms end module List = struct @@ -41,6 +50,7 @@ module List = struct let empty = [] let cons x xs = x :: xs let fold = List.fold_right + let fold_left = List.fold_left end include Generic (ListSequence) @@ -55,6 +65,7 @@ module FingerTree = struct let empty = BatFingerTree.empty let cons x xs = BatFingerTree.cons xs x let fold f xs acc = BatFingerTree.fold_right (Fun.flip f) acc xs + let fold_left = BatFingerTree.fold_left end include Generic (FingerTreeSequence) diff --git a/lib/Utilities.mli b/lib/Utilities.mli index 4ab7674..59bc1fc 100644 --- a/lib/Utilities.mli +++ b/lib/Utilities.mli @@ -11,6 +11,7 @@ end module List : sig val sequence : ('a, 'b) result list -> ('a list, 'b) result + val fold_left : ('a -> 'b -> ('a, 'e) result) -> 'a -> 'b list -> ('a, 'e) result val hd_opt : 'a list -> 'a option end @@ -31,6 +32,7 @@ module FingerTree : sig val map2 : ('a -> 'b -> 'c) -> 'a BatFingerTree.t -> 'b BatFingerTree.t -> 'c BatFingerTree.t val zip : 'a BatFingerTree.t -> 'b BatFingerTree.t -> ('a * 'b) BatFingerTree.t val sequence : ('a, 'b) result BatFingerTree.t -> ('a BatFingerTree.t, 'b) result + val fold_left : ('a -> 'b -> ('a, 'e) result) -> 'a -> 'b BatFingerTree.t -> ('a, 'e) result val join : string BatFingerTree.t -> string -> string end diff --git a/lib/evaluators/FOL.ml b/lib/evaluators/FOL.ml index d5c6851..92b1c38 100644 --- a/lib/evaluators/FOL.ml +++ b/lib/evaluators/FOL.ml @@ -92,15 +92,14 @@ let instantiate within = let restrict attributes description = let open Utilities.Result in - BatFingerTree.fold_left + Utilities.FingerTree.fold_left (fun restricted name -> - let* restricted = restricted in let* attribute = BatMap.String.find_opt name description |> Option.to_result ~none:(Error.unknown_attribute name) in Ok (BatMap.String.add name attribute restricted) ) - (Ok BatMap.String.empty) attributes + BatMap.String.empty attributes let rec describe = let open Utilities.Result in diff --git a/lib/kernel/Initialization.ml b/lib/kernel/Initialization.ml index 518fe4f..bcafce6 100644 --- a/lib/kernel/Initialization.ml +++ b/lib/kernel/Initialization.ml @@ -14,15 +14,7 @@ let bind namespace (name, handle) = let namespace entries = let into = Namespace.make () in - let open Utilities.Result in - let* () = - List.fold_left - (fun acc entry -> - let* () = acc in - bind into entry ) - (Ok ()) entries - in - Ok into + Utilities.List.fold_left (fun () -> bind into) () entries |> Result.map (fun () -> into) (* A subsystem's root holds what is its own and not data: its evaluators, and whatever else it registers beside them. *) diff --git a/lib/kernel/Merkle.ml b/lib/kernel/Merkle.ml index 266a560..78ab5a5 100644 --- a/lib/kernel/Merkle.ml +++ b/lib/kernel/Merkle.ml @@ -29,9 +29,7 @@ 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 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 @@ -330,11 +328,9 @@ functor 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 ) + Utilities.List.fold_left + (fun node (key, value) -> insert tx key value node) + empty bindings ) let rec fold_left tx f acc = let open Utilities.Result in @@ -344,12 +340,11 @@ functor |> BatFingerTree.fold_left (fun acc (k, v) -> f acc k v) acc |> Result.ok | Trunk {children; _} -> - BatFingerTree.fold_left + Utilities.FingerTree.fold_left (fun acc addr -> - let* acc = acc in let* node = find' tx addr in fold_left tx f acc node ) - (Ok acc) children + acc children let keys tx node = fold_left tx (fun acc k _ -> BatFingerTree.snoc acc k) BatFingerTree.empty node diff --git a/lib/kernel/Path.ml b/lib/kernel/Path.ml index 0814b1c..a6879b6 100644 --- a/lib/kernel/Path.ml +++ b/lib/kernel/Path.ml @@ -122,13 +122,12 @@ let assoc_all handle changes = in (* each step derives from the last; only the steps in between are ours to release *) - List.fold_left + Utilities.List.fold_left (fun current change -> - let* current = current in let* next = assoc_on current change in if current != node then Handle.release current; Ok next ) - (Ok node) + node (children @ List.map (fun (_, key, value) -> key, value) here) in apply [] handle changes |