diff options
| -rw-r--r-- | lib/Utilities.ml | 1 | ||||
| -rw-r--r-- | lib/Utilities.mli | 1 | ||||
| -rw-r--r-- | lib/kernel/Branch.ml | 2 | ||||
| -rw-r--r-- | lib/kernel/Multigroup.ml | 2 | ||||
| -rw-r--r-- | lib/kernel/Path.ml | 8 | ||||
| -rw-r--r-- | lib/kernel/Scope.ml | 4 |
6 files changed, 7 insertions, 11 deletions
diff --git a/lib/Utilities.ml b/lib/Utilities.ml index b7fe364..03d1eea 100644 --- a/lib/Utilities.ml +++ b/lib/Utilities.ml @@ -55,6 +55,7 @@ module List = struct include Generic (ListSequence) + let concat_map f xs = List.map f xs |> sequence |> Stdlib.Result.map List.concat let hd_opt = function x :: _ -> Some x | [] -> None end diff --git a/lib/Utilities.mli b/lib/Utilities.mli index 59bc1fc..fb38966 100644 --- a/lib/Utilities.mli +++ b/lib/Utilities.mli @@ -12,6 +12,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 concat_map : ('a -> ('b list, 'e) result) -> 'a list -> ('b list, 'e) result val hd_opt : 'a list -> 'a option end diff --git a/lib/kernel/Branch.ml b/lib/kernel/Branch.ml index 25c2e7b..561bff3 100644 --- a/lib/kernel/Branch.ml +++ b/lib/kernel/Branch.ml @@ -136,7 +136,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct object method check = let* named = Prototype.Directory.children multigroups in - List.map admits named |> Utilities.List.sequence |> Result.map List.concat + Utilities.List.concat_map admits named end; Prototype.Associative.( of_properties diff --git a/lib/kernel/Multigroup.ml b/lib/kernel/Multigroup.ml index 13ca7e0..9fbd386 100644 --- a/lib/kernel/Multigroup.ml +++ b/lib/kernel/Multigroup.ml @@ -226,7 +226,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct method check = let open Utilities.Result in let* named = Prototype.Directory.children (relations ?bind storage denial_tree) in - List.map (held ?bind) named |> Utilities.List.sequence |> Result.map List.concat + Utilities.List.concat_map (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 a6879b6..4859584 100644 --- a/lib/kernel/Path.ml +++ b/lib/kernel/Path.ml @@ -106,7 +106,7 @@ let assoc_all handle changes = | Some (_, key, _) -> Error (Error.overlapping_change (prefix @ [key])) | None -> let* children = - List.map + Utilities.List.concat_map (fun (x, beneath) -> let* dir = Handle.require Directory.from node in let* found = Directory.find dir x in @@ -117,8 +117,6 @@ let assoc_all handle changes = Handle.releasing child (fun () -> apply (prefix @ [x]) child beneath) |> Result.map (fun child' -> [x, Some child']) ) below - |> Utilities.List.sequence - |> Result.map List.concat in (* each step derives from the last; only the steps in between are ours to release *) @@ -156,7 +154,7 @@ let diff a b = let* left = names a in let* right = names b in List.sort_uniq String.compare (left @ right) - |> List.map (fun name -> + |> Utilities.List.concat_map (fun name -> let path = prefix @ [name] in let* x = find a name in let* y = find b name in @@ -170,7 +168,5 @@ let diff a b = let* below = walk path x y in Ok (if below = [] then [path] else below) | _ -> Ok [path] ) ) - |> Utilities.List.sequence - |> Result.map List.concat in walk [] a b diff --git a/lib/kernel/Scope.ml b/lib/kernel/Scope.ml index 23698ba..8868600 100644 --- a/lib/kernel/Scope.ml +++ b/lib/kernel/Scope.ml @@ -55,9 +55,7 @@ let catalog_of branch = Ok (List.map (name prefix) (BatFingerTree.to_list names)) | Some level, rest -> let* named = Prototype.Directory.children level in - List.map (fun (n, child) -> down (n :: prefix) child rest) named - |> Utilities.List.sequence - |> Result.map List.concat + Utilities.List.concat_map (fun (n, child) -> down (n :: prefix) child rest) named in down [] branch ["multigroup"; "schema"; "relation"] |