Merge pull request #1122 from rgrinberg/result-iter

Simplify Result code with Combinators

src/inline_tests.ml

@@ -65,10 +65,10 @@ module Backend = struct
       { info
       ; lib
       ; runner_libraries =
-          Result.all (List.map info.runner_libraries ~f:resolve)
+          Result.List.all (List.map info.runner_libraries ~f:resolve)
       ; extends =
           let open Result.O in
-          Result.all
+          Result.List.all
             (List.map info.extends
                ~f:(fun ((loc, name) as x) ->
                  resolve x >>= fun lib ->
@@ -182,12 +182,12 @@ include Sub_system.Register_end_point(
 
       let runner_libs =
         let open Result.O in
-        Result.concat_map backends
+        Result.List.concat_map backends
           ~f:(fun (backend : Backend.t) -> backend.runner_libraries)
         >>= fun libs ->
         Lib.DB.find_many (Scope.libs scope) [lib.name]
         >>= fun lib ->
-        Result.all
+        Result.List.all
           (List.map info.libraries
              ~f:(Lib.DB.resolve (Scope.libs scope)))
         >>= fun more_libs ->

src/lib.ml

@@ -575,7 +575,7 @@ module Dep_stack = struct
          }
 end
 
-let check_private_deps ~(lib : lib) ~loc ~allow_private_deps =
+let check_private_deps lib ~loc ~allow_private_deps =
   if (not allow_private_deps) && Status.is_private lib.info.status then
     Result.Error (Error (
       Private_deps_not_allowed { private_dep = lib ; pd_loc = loc }))
@@ -689,7 +689,7 @@ and resolve_dep db name ~allow_private_deps ~loc ~stack : t Or_exn.t =
   match find_internal db name ~stack with
   | St_initializing id ->
     Error (Dep_stack.dependency_cycle stack id)
-  | St_found lib -> check_private_deps ~lib ~loc ~allow_private_deps
+  | St_found lib -> check_private_deps lib ~loc ~allow_private_deps
   | St_not_found ->
     Error (Error (Library_not_available { loc; name; reason = Not_found }))
   | St_hidden (_, hidden) ->
@@ -733,13 +733,8 @@ and available_internal db name ~stack =
   | Error _ -> false
 
 and resolve_simple_deps db names ~allow_private_deps ~stack =
-  let rec loop acc = function
-    | [] -> Ok (List.rev acc)
-    | (loc, name) :: names ->
-      resolve_dep db name ~allow_private_deps ~loc ~stack >>= fun x ->
-      loop (x :: acc) names
-  in
-  loop [] names
+  Result.List.map names ~f:(fun (loc, name) ->
+    resolve_dep db name ~allow_private_deps ~loc ~stack)
 
 and resolve_complex_deps db deps ~allow_private_deps ~stack =
   let res, resolved_selects =
@@ -822,7 +817,7 @@ and resolve_user_deps db deps ~allow_private_deps ~pps ~stack =
         let rec check_runtime_deps acc pps = function
           | [] -> loop acc pps
           | lib :: ppx_rts ->
-            check_private_deps ~lib ~loc ~allow_private_deps >>= fun rt ->
+            check_private_deps lib ~loc ~allow_private_deps >>= fun rt ->
             check_runtime_deps (rt :: acc) pps ppx_rts
         and loop acc = function
           | [] -> Ok acc
@@ -838,7 +833,7 @@ and resolve_user_deps db deps ~allow_private_deps ~pps ~stack =
   in
   (deps, pps, resolved_selects)
 
-and closure_with_overlap_checks db ts ~stack =
+  and closure_with_overlap_checks db ts ~stack =
   let visited = ref String.Map.empty in
   let res = ref [] in
   let orig_stack = stack in
@@ -874,16 +869,10 @@ and closure_with_overlap_checks db ts ~stack =
       >>= fun () ->
       Dep_stack.push stack (to_id t) >>= fun stack ->
       t.requires >>= fun deps ->
-      iter deps ~stack >>| fun () ->
+      Result.List.iter deps ~f:(loop ~stack) >>| fun () ->
       res := t :: !res
-  and iter ts ~stack =
-    match ts with
-    | [] -> Ok ()
-    | t :: ts ->
-      loop t ~stack >>= fun () ->
-      iter ts ~stack
   in
-  iter ts ~stack >>| fun () ->
+  Result.List.iter ts ~f:(loop ~stack) >>| fun () ->
   List.rev !res
 
 let closure_with_overlap_checks db l =
@@ -1035,14 +1024,8 @@ module DB = struct
                       ; reason
                       }))
 
-  let find_many =
-    let rec loop t acc = function
-      | [] -> Ok (List.rev acc)
-      | name :: names ->
-        resolve t (Loc.none, name) >>= fun lib ->
-        loop t (lib ::acc) names
-    in
-    fun t names -> loop t [] names
+  let find_many t =
+    Result.List.map ~f:(fun name -> resolve t (Loc.none, name))
 
   let available t name = available_internal t name ~stack:Dep_stack.empty
 

src/preprocessing.ml

@@ -85,7 +85,7 @@ module Driver = struct
       ; lib = lazy lib
       ; replaces =
           let open Result.O in
-          Result.all
+          Result.List.all
             (List.map info.replaces
                ~f:(fun ((loc, name) as x) ->
                  resolve x >>= fun lib ->

src/stdune/result.ml

@@ -41,22 +41,40 @@ end
 
 open O
 
-let all =
-  let rec loop acc = function
-    | [] -> Ok (List.rev acc)
-    | t :: l ->
-      t >>= fun x ->
-      loop (x :: acc) l
-  in
-  fun l -> loop [] l
-
-let concat_map =
-  let rec loop f acc = function
-    | [] -> Ok (List.rev acc)
-    | x :: l ->
-      f x >>= fun y ->
-      loop f (List.rev_append y acc) l
-  in
-  fun l ~f -> loop f [] l
-
 type ('a, 'error) result = ('a, 'error) t
+
+module List = struct
+  let map t ~f =
+    let rec loop acc = function
+      | [] -> Ok (List.rev acc)
+      | x :: xs ->
+        f x >>= fun x ->
+        loop (x :: acc) xs
+    in
+    loop [] t
+
+  let all =
+    let rec loop acc = function
+      | [] -> Ok (List.rev acc)
+      | t :: l ->
+        t >>= fun x ->
+        loop (x :: acc) l
+    in
+    fun l -> loop [] l
+
+  let concat_map =
+    let rec loop f acc = function
+      | [] -> Ok (List.rev acc)
+      | x :: l ->
+        f x >>= fun y ->
+        loop f (List.rev_append y acc) l
+    in
+    fun l ~f -> loop f [] l
+
+  let rec iter t ~f =
+    match t with
+    | [] -> Ok ()
+    | x :: xs ->
+      f x >>= fun () ->
+      iter xs ~f
+end

src/stdune/result.mli

@@ -21,15 +21,21 @@ val bind : ('a, 'error) t -> f:('a -> ('b, 'error) t) -> ('b, 'error) t
 
 val map_error : ('a, 'error1) t -> f:('error1 -> 'error2) -> ('a, 'error2) t
 
-val all : ('a, 'error) t list -> ('a list, 'error) t
-
-val concat_map
-  :  'a list
-  -> f:('a -> ('b list, 'error) t)
-  -> ('b list, 'error) t
-
 (** Produce [Error <message>] *)
 val errorf : ('a, unit, string, (_, string) t) format4 -> 'a
 
 (** For compatibility with some other code *)
 type ('a, 'error) result = ('a, 'error) t
+
+module List : sig
+  val map : 'a list -> f:('a -> ('b, 'e) t) -> ('b list, 'e) t
+
+  val all : ('a, 'error) t list -> ('a list, 'error) t
+
+  val iter : 'a list -> f:('a -> (unit, 'error) t) -> (unit, 'error) t
+
+  val concat_map
+    :  'a list
+    -> f:('a -> ('b list, 'error) t)
+    -> ('b list, 'error) t
+end

src/sub_system.ml

@@ -107,7 +107,7 @@ module Register_backend(M : Backend) = struct
     let open Result.O in
     written_by_user_or_scan ~written_by_user ~to_scan
     >>= fun backends ->
-    wrap (Result.concat_map backends ~f:replaces)
+    wrap (Result.List.concat_map backends ~f:replaces)
     >>= fun replaced_backends ->
     match
       Set.diff (Set.of_list backends) (Set.of_list replaced_backends)
@@ -131,7 +131,7 @@ module Register_end_point(M : End_point) = struct
       (match M.Info.backends info with
        | None -> Ok None
        | Some l ->
-         Result.all (List.map l ~f:(M.Backend.resolve (Scope.libs c.scope)))
+         Result.List.all (List.map l ~f:(M.Backend.resolve (Scope.libs c.scope)))
          >>| Option.some)
       >>= fun written_by_user ->
       M.Backend.Selection_error.or_exn ~loc:(M.Info.loc info)