concat map

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"]